gcc/fortran/check.c

   1 /* Check functions
   2    Copyright (C) 2002-2018 Free Software Foundation, Inc.
   3    Contributed by Andy Vaught & Katherine Holcomb
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21
  22 /* These functions check to see if an argument list is compatible with
  23    a particular intrinsic function or subroutine.  Presence of
  24    required arguments has already been established, the argument list
  25    has been sorted into the right order and has NULL arguments in the
  26    correct places for missing optional arguments.  */
  27
  28 #include "config.h"
  29 #include "system.h"
  30 #include "coretypes.h"
  31 #include "options.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 bool
  41 scalar_check (gfc_expr *e, int n)
  42 {
  43   if (e->rank == 0)
  44     return true;
  45
  46   gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
  47              gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
  48              &e->where);
  49
  50   return false;
  51 }
  52
  53
  54 /* Check the type of an expression.  */
  55
  56 static bool
  57 type_check (gfc_expr *e, int n, bt type)
  58 {
  59   if (e->ts.type == type)
  60     return true;
  61
  62   gfc_error ("%qs argument of %qs 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 false;
  67 }
  68
  69
  70 /* Check that the expression is a numeric type.  */
  71
  72 static bool
  73 numeric_check (gfc_expr *e, int n)
  74 {
  75   /* Users sometime use a subroutine designator as an actual argument to
  76      an intrinsic subprogram that expects an argument with a numeric type.  */
  77   if (e->symtree && e->symtree->n.sym->attr.subroutine)
  78     goto error;
  79
  80   if (gfc_numeric_ts (&e->ts))
  81     return true;
  82
  83   /* If the expression has not got a type, check if its namespace can
  84      offer a default type.  */
  85   if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
  86         && e->symtree->n.sym->ts.type == BT_UNKNOWN
  87         && gfc_set_default_type (e->symtree->n.sym, 0, e->symtree->n.sym->ns)
  88         && gfc_numeric_ts (&e->symtree->n.sym->ts))
  89     {
  90       e->ts = e->symtree->n.sym->ts;
  91       return true;
  92     }
  93
  94 error:
  95
  96   gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
  97              gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
  98              &e->where);
  99
 100   return false;
 101 }
 102
 103
 104 /* Check that an expression is integer or real.  */
 105
 106 static bool
 107 int_or_real_check (gfc_expr *e, int n)
 108 {
 109   if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
 110     {
 111       gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
 112                  "or REAL", gfc_current_intrinsic_arg[n]->name,
 113                  gfc_current_intrinsic, &e->where);
 114       return false;
 115     }
 116
 117   return true;
 118 }
 119
 120 /* Check that an expression is integer or real; allow character for
 121    F2003 or later.  */
 122
 123 static bool
 124 int_or_real_or_char_check_f2003 (gfc_expr *e, int n)
 125 {
 126   if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
 127     {
 128       if (e->ts.type == BT_CHARACTER)
 129         return gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Character for "
 130                                "%qs argument of %qs intrinsic at %L",
 131                                gfc_current_intrinsic_arg[n]->name,
 132                                gfc_current_intrinsic, &e->where);
 133       else
 134         {
 135           if (gfc_option.allow_std & GFC_STD_F2003)
 136             gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
 137                        "or REAL or CHARACTER",
 138                        gfc_current_intrinsic_arg[n]->name,
 139                        gfc_current_intrinsic, &e->where);
 140           else
 141             gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
 142                        "or REAL", gfc_current_intrinsic_arg[n]->name,
 143                        gfc_current_intrinsic, &e->where);
 144         }
 145       return false;
 146     }
 147
 148   return true;
 149 }
 150
 151 /* Check that an expression is an intrinsic type.  */
 152 static bool
 153 intrinsic_type_check (gfc_expr *e, int n)
 154 {
 155   if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL
 156       && e->ts.type != BT_COMPLEX && e->ts.type != BT_CHARACTER
 157       && e->ts.type != BT_LOGICAL)
 158     {
 159       gfc_error ("%qs argument of %qs intrinsic at %L must be of intrinsic type",
 160                  gfc_current_intrinsic_arg[n]->name,
 161                  gfc_current_intrinsic, &e->where);
 162       return false;
 163     }
 164   return true;
 165 }
 166
 167 /* Check that an expression is real or complex.  */
 168
 169 static bool
 170 real_or_complex_check (gfc_expr *e, int n)
 171 {
 172   if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
 173     {
 174       gfc_error ("%qs argument of %qs intrinsic at %L must be REAL "
 175                  "or COMPLEX", gfc_current_intrinsic_arg[n]->name,
 176                  gfc_current_intrinsic, &e->where);
 177       return false;
 178     }
 179
 180   return true;
 181 }
 182
 183
 184 /* Check that an expression is INTEGER or PROCEDURE.  */
 185
 186 static bool
 187 int_or_proc_check (gfc_expr *e, int n)
 188 {
 189   if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
 190     {
 191       gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
 192                  "or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
 193                  gfc_current_intrinsic, &e->where);
 194       return false;
 195     }
 196
 197   return true;
 198 }
 199
 200
 201 /* Check that the expression is an optional constant integer
 202    and that it specifies a valid kind for that type.  */
 203
 204 static bool
 205 kind_check (gfc_expr *k, int n, bt type)
 206 {
 207   int kind;
 208
 209   if (k == NULL)
 210     return true;
 211
 212   if (!type_check (k, n, BT_INTEGER))
 213     return false;
 214
 215   if (!scalar_check (k, n))
 216     return false;
 217
 218   if (!gfc_check_init_expr (k))
 219     {
 220       gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
 221                  gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 222                  &k->where);
 223       return false;
 224     }
 225
 226   if (gfc_extract_int (k, &kind)
 227       || gfc_validate_kind (type, kind, true) < 0)
 228     {
 229       gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
 230                  &k->where);
 231       return false;
 232     }
 233
 234   return true;
 235 }
 236
 237
 238 /* Make sure the expression is a double precision real.  */
 239
 240 static bool
 241 double_check (gfc_expr *d, int n)
 242 {
 243   if (!type_check (d, n, BT_REAL))
 244     return false;
 245
 246   if (d->ts.kind != gfc_default_double_kind)
 247     {
 248       gfc_error ("%qs argument of %qs intrinsic at %L must be double "
 249                  "precision", gfc_current_intrinsic_arg[n]->name,
 250                  gfc_current_intrinsic, &d->where);
 251       return false;
 252     }
 253
 254   return true;
 255 }
 256
 257
 258 static bool
 259 coarray_check (gfc_expr *e, int n)
 260 {
 261   if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
 262         && CLASS_DATA (e)->attr.codimension
 263         && CLASS_DATA (e)->as->corank)
 264     {
 265       gfc_add_class_array_ref (e);
 266       return true;
 267     }
 268
 269   if (!gfc_is_coarray (e))
 270     {
 271       gfc_error ("Expected coarray variable as %qs argument to the %s "
 272                  "intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
 273                  gfc_current_intrinsic, &e->where);
 274       return false;
 275     }
 276
 277   return true;
 278 }
 279
 280
 281 /* Make sure the expression is a logical array.  */
 282
 283 static bool
 284 logical_array_check (gfc_expr *array, int n)
 285 {
 286   if (array->ts.type != BT_LOGICAL || array->rank == 0)
 287     {
 288       gfc_error ("%qs argument of %qs intrinsic at %L must be a logical "
 289                  "array", gfc_current_intrinsic_arg[n]->name,
 290                  gfc_current_intrinsic, &array->where);
 291       return false;
 292     }
 293
 294   return true;
 295 }
 296
 297
 298 /* Make sure an expression is an array.  */
 299
 300 static bool
 301 array_check (gfc_expr *e, int n)
 302 {
 303   if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
 304         && CLASS_DATA (e)->attr.dimension
 305         && CLASS_DATA (e)->as->rank)
 306     {
 307       gfc_add_class_array_ref (e);
 308       return true;
 309     }
 310
 311   if (e->rank != 0 && e->ts.type != BT_PROCEDURE)
 312     return true;
 313
 314   gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
 315              gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 316              &e->where);
 317
 318   return false;
 319 }
 320
 321
 322 /* If expr is a constant, then check to ensure that it is greater than
 323    of equal to zero.  */
 324
 325 static bool
 326 nonnegative_check (const char *arg, gfc_expr *expr)
 327 {
 328   int i;
 329
 330   if (expr->expr_type == EXPR_CONSTANT)
 331     {
 332       gfc_extract_int (expr, &i);
 333       if (i < 0)
 334         {
 335           gfc_error ("%qs at %L must be nonnegative", arg, &expr->where);
 336           return false;
 337         }
 338     }
 339
 340   return true;
 341 }
 342
 343
 344 /* If expr is a constant, then check to ensure that it is greater than zero.  */
 345
 346 static bool
 347 positive_check (int n, gfc_expr *expr)
 348 {
 349   int i;
 350
 351   if (expr->expr_type == EXPR_CONSTANT)
 352     {
 353       gfc_extract_int (expr, &i);
 354       if (i <= 0)
 355         {
 356           gfc_error ("%qs argument of %qs intrinsic at %L must be positive",
 357                      gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 358                      &expr->where);
 359           return false;
 360         }
 361     }
 362
 363   return true;
 364 }
 365
 366
 367 /* If expr2 is constant, then check that the value is less than
 368    (less than or equal to, if 'or_equal' is true) bit_size(expr1).  */
 369
 370 static bool
 371 less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
 372                     gfc_expr *expr2, bool or_equal)
 373 {
 374   int i2, i3;
 375
 376   if (expr2->expr_type == EXPR_CONSTANT)
 377     {
 378       gfc_extract_int (expr2, &i2);
 379       i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
 380
 381       /* For ISHFT[C], check that |shift| <= bit_size(i).  */
 382       if (arg2 == NULL)
 383         {
 384           if (i2 < 0)
 385             i2 = -i2;
 386
 387           if (i2 > gfc_integer_kinds[i3].bit_size)
 388             {
 389               gfc_error ("The absolute value of SHIFT at %L must be less "
 390                          "than or equal to BIT_SIZE(%qs)",
 391                          &expr2->where, arg1);
 392               return false;
 393             }
 394         }
 395
 396       if (or_equal)
 397         {
 398           if (i2 > gfc_integer_kinds[i3].bit_size)
 399             {
 400               gfc_error ("%qs at %L must be less than "
 401                          "or equal to BIT_SIZE(%qs)",
 402                          arg2, &expr2->where, arg1);
 403               return false;
 404             }
 405         }
 406       else
 407         {
 408           if (i2 >= gfc_integer_kinds[i3].bit_size)
 409             {
 410               gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
 411                          arg2, &expr2->where, arg1);
 412               return false;
 413             }
 414         }
 415     }
 416
 417   return true;
 418 }
 419
 420
 421 /* If expr is constant, then check that the value is less than or equal
 422    to the bit_size of the kind k.  */
 423
 424 static bool
 425 less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
 426 {
 427   int i, val;
 428
 429   if (expr->expr_type != EXPR_CONSTANT)
 430     return true;
 431
 432   i = gfc_validate_kind (BT_INTEGER, k, false);
 433   gfc_extract_int (expr, &val);
 434
 435   if (val > gfc_integer_kinds[i].bit_size)
 436     {
 437       gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
 438                  "INTEGER(KIND=%d)", arg, &expr->where, k);
 439       return false;
 440     }
 441
 442   return true;
 443 }
 444
 445
 446 /* If expr2 and expr3 are constants, then check that the value is less than
 447    or equal to bit_size(expr1).  */
 448
 449 static bool
 450 less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
 451                gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
 452 {
 453   int i2, i3;
 454
 455   if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
 456     {
 457       gfc_extract_int (expr2, &i2);
 458       gfc_extract_int (expr3, &i3);
 459       i2 += i3;
 460       i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
 461       if (i2 > gfc_integer_kinds[i3].bit_size)
 462         {
 463           gfc_error ("%<%s + %s%> at %L must be less than or equal "
 464                      "to BIT_SIZE(%qs)",
 465                      arg2, arg3, &expr2->where, arg1);
 466           return false;
 467         }
 468     }
 469
 470   return true;
 471 }
 472
 473 /* Make sure two expressions have the same type.  */
 474
 475 static bool
 476 same_type_check (gfc_expr *e, int n, gfc_expr *f, int m, bool assoc = false)
 477 {
 478   gfc_typespec *ets = &e->ts;
 479   gfc_typespec *fts = &f->ts;
 480
 481   if (assoc)
 482     {
 483       /* Procedure pointer component expressions have the type of the interface
 484          procedure. If they are being tested for association with a procedure
 485          pointer (ie. not a component), the type of the procedure must be
 486          determined.  */
 487       if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym)
 488         ets = &e->symtree->n.sym->ts;
 489       if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym)
 490         fts = &f->symtree->n.sym->ts;
 491     }
 492
 493   if (gfc_compare_types (ets, fts))
 494     return true;
 495
 496   gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
 497              "and kind as %qs", gfc_current_intrinsic_arg[m]->name,
 498              gfc_current_intrinsic, &f->where,
 499              gfc_current_intrinsic_arg[n]->name);
 500
 501   return false;
 502 }
 503
 504
 505 /* Make sure that an expression has a certain (nonzero) rank.  */
 506
 507 static bool
 508 rank_check (gfc_expr *e, int n, int rank)
 509 {
 510   if (e->rank == rank)
 511     return true;
 512
 513   gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
 514              gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 515              &e->where, rank);
 516
 517   return false;
 518 }
 519
 520
 521 /* Make sure a variable expression is not an optional dummy argument.  */
 522
 523 static bool
 524 nonoptional_check (gfc_expr *e, int n)
 525 {
 526   if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
 527     {
 528       gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
 529                  gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 530                  &e->where);
 531     }
 532
 533   /* TODO: Recursive check on nonoptional variables?  */
 534
 535   return true;
 536 }
 537
 538
 539 /* Check for ALLOCATABLE attribute.  */
 540
 541 static bool
 542 allocatable_check (gfc_expr *e, int n)
 543 {
 544   symbol_attribute attr;
 545
 546   attr = gfc_variable_attr (e, NULL);
 547   if (!attr.allocatable || attr.associate_var)
 548     {
 549       gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE",
 550                  gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 551                  &e->where);
 552       return false;
 553     }
 554
 555   return true;
 556 }
 557
 558
 559 /* Check that an expression has a particular kind.  */
 560
 561 static bool
 562 kind_value_check (gfc_expr *e, int n, int k)
 563 {
 564   if (e->ts.kind == k)
 565     return true;
 566
 567   gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d",
 568              gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 569              &e->where, k);
 570
 571   return false;
 572 }
 573
 574
 575 /* Make sure an expression is a variable.  */
 576
 577 static bool
 578 variable_check (gfc_expr *e, int n, bool allow_proc)
 579 {
 580   if (e->expr_type == EXPR_VARIABLE
 581       && e->symtree->n.sym->attr.intent == INTENT_IN
 582       && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
 583           || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT))
 584     {
 585       gfc_ref *ref;
 586       bool pointer = e->symtree->n.sym->ts.type == BT_CLASS
 587                      && CLASS_DATA (e->symtree->n.sym)
 588                      ? CLASS_DATA (e->symtree->n.sym)->attr.class_pointer
 589                      : e->symtree->n.sym->attr.pointer;
 590
 591       for (ref = e->ref; ref; ref = ref->next)
 592         {
 593           if (pointer && ref->type == REF_COMPONENT)
 594             break;
 595           if (ref->type == REF_COMPONENT
 596               && ((ref->u.c.component->ts.type == BT_CLASS
 597                    && CLASS_DATA (ref->u.c.component)->attr.class_pointer)
 598                   || (ref->u.c.component->ts.type != BT_CLASS
 599                       && ref->u.c.component->attr.pointer)))
 600             break;
 601         }
 602
 603       if (!ref)
 604         {
 605           gfc_error ("%qs argument of %qs intrinsic at %L cannot be "
 606                      "INTENT(IN)", gfc_current_intrinsic_arg[n]->name,
 607                      gfc_current_intrinsic, &e->where);
 608           return false;
 609         }
 610     }
 611
 612   if (e->expr_type == EXPR_VARIABLE
 613       && e->symtree->n.sym->attr.flavor != FL_PARAMETER
 614       && (allow_proc || !e->symtree->n.sym->attr.function))
 615     return true;
 616
 617   if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function
 618       && e->symtree->n.sym == e->symtree->n.sym->result)
 619     {
 620       gfc_namespace *ns;
 621       for (ns = gfc_current_ns; ns; ns = ns->parent)
 622         if (ns->proc_name == e->symtree->n.sym)
 623           return true;
 624     }
 625
 626   gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
 627              gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
 628
 629   return false;
 630 }
 631
 632
 633 /* Check the common DIM parameter for correctness.  */
 634
 635 static bool
 636 dim_check (gfc_expr *dim, int n, bool optional)
 637 {
 638   if (dim == NULL)
 639     return true;
 640
 641   if (!type_check (dim, n, BT_INTEGER))
 642     return false;
 643
 644   if (!scalar_check (dim, n))
 645     return false;
 646
 647   if (!optional && !nonoptional_check (dim, n))
 648     return false;
 649
 650   return true;
 651 }
 652
 653
 654 /* If a coarray DIM parameter is a constant, make sure that it is greater than
 655    zero and less than or equal to the corank of the given array.  */
 656
 657 static bool
 658 dim_corank_check (gfc_expr *dim, gfc_expr *array)
 659 {
 660   int corank;
 661
 662   gcc_assert (array->expr_type == EXPR_VARIABLE);
 663
 664   if (dim->expr_type != EXPR_CONSTANT)
 665     return true;
 666
 667   if (array->ts.type == BT_CLASS)
 668     return true;
 669
 670   corank = gfc_get_corank (array);
 671
 672   if (mpz_cmp_ui (dim->value.integer, 1) < 0
 673       || mpz_cmp_ui (dim->value.integer, corank) > 0)
 674     {
 675       gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
 676                  "codimension index", gfc_current_intrinsic, &dim->where);
 677
 678       return false;
 679     }
 680
 681   return true;
 682 }
 683
 684
 685 /* If a DIM parameter is a constant, make sure that it is greater than
 686    zero and less than or equal to the rank of the given array.  If
 687    allow_assumed is zero then dim must be less than the rank of the array
 688    for assumed size arrays.  */
 689
 690 static bool
 691 dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
 692 {
 693   gfc_array_ref *ar;
 694   int rank;
 695
 696   if (dim == NULL)
 697     return true;
 698
 699   if (dim->expr_type != EXPR_CONSTANT)
 700     return true;
 701
 702   if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
 703       && array->value.function.isym->id == GFC_ISYM_SPREAD)
 704     rank = array->rank + 1;
 705   else
 706     rank = array->rank;
 707
 708   /* Assumed-rank array.  */
 709   if (rank == -1)
 710     rank = GFC_MAX_DIMENSIONS;
 711
 712   if (array->expr_type == EXPR_VARIABLE)
 713     {
 714       ar = gfc_find_array_ref (array);
 715       if (ar->as->type == AS_ASSUMED_SIZE
 716           && !allow_assumed
 717           && ar->type != AR_ELEMENT
 718           && ar->type != AR_SECTION)
 719         rank--;
 720     }
 721
 722   if (mpz_cmp_ui (dim->value.integer, 1) < 0
 723       || mpz_cmp_ui (dim->value.integer, rank) > 0)
 724     {
 725       gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
 726                  "dimension index", gfc_current_intrinsic, &dim->where);
 727
 728       return false;
 729     }
 730
 731   return true;
 732 }
 733
 734
 735 /* Compare the size of a along dimension ai with the size of b along
 736    dimension bi, returning 0 if they are known not to be identical,
 737    and 1 if they are identical, or if this cannot be determined.  */
 738
 739 static int
 740 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
 741 {
 742   mpz_t a_size, b_size;
 743   int ret;
 744
 745   gcc_assert (a->rank > ai);
 746   gcc_assert (b->rank > bi);
 747
 748   ret = 1;
 749
 750   if (gfc_array_dimen_size (a, ai, &a_size))
 751     {
 752       if (gfc_array_dimen_size (b, bi, &b_size))
 753         {
 754           if (mpz_cmp (a_size, b_size) != 0)
 755             ret = 0;
 756
 757           mpz_clear (b_size);
 758         }
 759       mpz_clear (a_size);
 760     }
 761   return ret;
 762 }
 763
 764 /*  Calculate the length of a character variable, including substrings.
 765     Strip away parentheses if necessary.  Return -1 if no length could
 766     be determined.  */
 767
 768 static long
 769 gfc_var_strlen (const gfc_expr *a)
 770 {
 771   gfc_ref *ra;
 772
 773   while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES)
 774     a = a->value.op.op1;
 775
 776   for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next)
 777     ;
 778
 779   if (ra)
 780     {
 781       long start_a, end_a;
 782
 783       if (!ra->u.ss.end)
 784         return -1;
 785
 786       if ((!ra->u.ss.start || ra->u.ss.start->expr_type == EXPR_CONSTANT)
 787           && ra->u.ss.end->expr_type == EXPR_CONSTANT)
 788         {
 789           start_a = ra->u.ss.start ? mpz_get_si (ra->u.ss.start->value.integer)
 790                                    : 1;
 791           end_a = mpz_get_si (ra->u.ss.end->value.integer);
 792           return (end_a < start_a) ? 0 : end_a - start_a + 1;
 793         }
 794       else if (ra->u.ss.start
 795                && gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
 796         return 1;
 797       else
 798         return -1;
 799     }
 800
 801   if (a->ts.u.cl && a->ts.u.cl->length
 802       && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
 803     return mpz_get_si (a->ts.u.cl->length->value.integer);
 804   else if (a->expr_type == EXPR_CONSTANT
 805            && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
 806     return a->value.character.length;
 807   else
 808     return -1;
 809
 810 }
 811
 812 /* Check whether two character expressions have the same length;
 813    returns true if they have or if the length cannot be determined,
 814    otherwise return false and raise a gfc_error.  */
 815
 816 bool
 817 gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
 818 {
 819    long len_a, len_b;
 820
 821    len_a = gfc_var_strlen(a);
 822    len_b = gfc_var_strlen(b);
 823
 824    if (len_a == -1 || len_b == -1 || len_a == len_b)
 825      return true;
 826    else
 827      {
 828        gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
 829                   len_a, len_b, name, &a->where);
 830        return false;
 831      }
 832 }
 833
 834
 835 /***** Check functions *****/
 836
 837 /* Check subroutine suitable for intrinsics taking a real argument and
 838    a kind argument for the result.  */
 839
 840 static bool
 841 check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
 842 {
 843   if (!type_check (a, 0, BT_REAL))
 844     return false;
 845   if (!kind_check (kind, 1, type))
 846     return false;
 847
 848   return true;
 849 }
 850
 851
 852 /* Check subroutine suitable for ceiling, floor and nint.  */
 853
 854 bool
 855 gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
 856 {
 857   return check_a_kind (a, kind, BT_INTEGER);
 858 }
 859
 860
 861 /* Check subroutine suitable for aint, anint.  */
 862
 863 bool
 864 gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
 865 {
 866   return check_a_kind (a, kind, BT_REAL);
 867 }
 868
 869
 870 bool
 871 gfc_check_abs (gfc_expr *a)
 872 {
 873   if (!numeric_check (a, 0))
 874     return false;
 875
 876   return true;
 877 }
 878
 879
 880 bool
 881 gfc_check_achar (gfc_expr *a, gfc_expr *kind)
 882 {
 883   if (!type_check (a, 0, BT_INTEGER))
 884     return false;
 885   if (!kind_check (kind, 1, BT_CHARACTER))
 886     return false;
 887
 888   return true;
 889 }
 890
 891
 892 bool
 893 gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
 894 {
 895   if (!type_check (name, 0, BT_CHARACTER)
 896       || !scalar_check (name, 0))
 897     return false;
 898   if (!kind_value_check (name, 0, gfc_default_character_kind))
 899     return false;
 900
 901   if (!type_check (mode, 1, BT_CHARACTER)
 902       || !scalar_check (mode, 1))
 903     return false;
 904   if (!kind_value_check (mode, 1, gfc_default_character_kind))
 905     return false;
 906
 907   return true;
 908 }
 909
 910
 911 bool
 912 gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
 913 {
 914   if (!logical_array_check (mask, 0))
 915     return false;
 916
 917   if (!dim_check (dim, 1, false))
 918     return false;
 919
 920   if (!dim_rank_check (dim, mask, 0))
 921     return false;
 922
 923   return true;
 924 }
 925
 926
 927 bool
 928 gfc_check_allocated (gfc_expr *array)
 929 {
 930   /* Tests on allocated components of coarrays need to detour the check to
 931      argument of the _caf_get.  */
 932   if (flag_coarray == GFC_FCOARRAY_LIB && array->expr_type == EXPR_FUNCTION
 933       && array->value.function.isym
 934       && array->value.function.isym->id == GFC_ISYM_CAF_GET)
 935     {
 936       array = array->value.function.actual->expr;
 937       if (!array->ref)
 938         return false;
 939     }
 940
 941   if (!variable_check (array, 0, false))
 942     return false;
 943   if (!allocatable_check (array, 0))
 944     return false;
 945
 946   return true;
 947 }
 948
 949
 950 /* Common check function where the first argument must be real or
 951    integer and the second argument must be the same as the first.  */
 952
 953 bool
 954 gfc_check_a_p (gfc_expr *a, gfc_expr *p)
 955 {
 956   if (!int_or_real_check (a, 0))
 957     return false;
 958
 959   if (a->ts.type != p->ts.type)
 960     {
 961       gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
 962                  "have the same type", gfc_current_intrinsic_arg[0]->name,
 963                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
 964                  &p->where);
 965       return false;
 966     }
 967
 968   if (a->ts.kind != p->ts.kind)
 969     {
 970       if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
 971                            &p->where))
 972        return false;
 973     }
 974
 975   return true;
 976 }
 977
 978
 979 bool
 980 gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
 981 {
 982   if (!double_check (x, 0) || !double_check (y, 1))
 983     return false;
 984
 985   return true;
 986 }
 987
 988
 989 bool
 990 gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
 991 {
 992   symbol_attribute attr1, attr2;
 993   int i;
 994   bool t;
 995   locus *where;
 996
 997   where = &pointer->where;
 998
 999   if (pointer->expr_type == EXPR_NULL)
1000     goto null_arg;
1001
1002   attr1 = gfc_expr_attr (pointer);
1003
1004   if (!attr1.pointer && !attr1.proc_pointer)
1005     {
1006       gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
1007                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
1008                  &pointer->where);
1009       return false;
1010     }
1011
1012   /* F2008, C1242.  */
1013   if (attr1.pointer && gfc_is_coindexed (pointer))
1014     {
1015       gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1016                  "coindexed", gfc_current_intrinsic_arg[0]->name,
1017                  gfc_current_intrinsic, &pointer->where);
1018       return false;
1019     }
1020
1021   /* Target argument is optional.  */
1022   if (target == NULL)
1023     return true;
1024
1025   where = &target->where;
1026   if (target->expr_type == EXPR_NULL)
1027     goto null_arg;
1028
1029   if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
1030     attr2 = gfc_expr_attr (target);
1031   else
1032     {
1033       gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
1034                  "or target VARIABLE or FUNCTION",
1035                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1036                  &target->where);
1037       return false;
1038     }
1039
1040   if (attr1.pointer && !attr2.pointer && !attr2.target)
1041     {
1042       gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
1043                  "or a TARGET", gfc_current_intrinsic_arg[1]->name,
1044                  gfc_current_intrinsic, &target->where);
1045       return false;
1046     }
1047
1048   /* F2008, C1242.  */
1049   if (attr1.pointer && gfc_is_coindexed (target))
1050     {
1051       gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1052                  "coindexed", gfc_current_intrinsic_arg[1]->name,
1053                  gfc_current_intrinsic, &target->where);
1054       return false;
1055     }
1056
1057   t = true;
1058   if (!same_type_check (pointer, 0, target, 1, true))
1059     t = false;
1060   if (!rank_check (target, 0, pointer->rank))
1061     t = false;
1062   if (target->rank > 0)
1063     {
1064       for (i = 0; i < target->rank; i++)
1065         if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1066           {
1067             gfc_error ("Array section with a vector subscript at %L shall not "
1068                        "be the target of a pointer",
1069                        &target->where);
1070             t = false;
1071             break;
1072           }
1073     }
1074   return t;
1075
1076 null_arg:
1077
1078   gfc_error ("NULL pointer at %L is not permitted as actual argument "
1079              "of %qs intrinsic function", where, gfc_current_intrinsic);
1080   return false;
1081
1082 }
1083
1084
1085 bool
1086 gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
1087 {
1088   /* gfc_notify_std would be a waste of time as the return value
1089      is seemingly used only for the generic resolution.  The error
1090      will be: Too many arguments.  */
1091   if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
1092     return false;
1093
1094   return gfc_check_atan2 (y, x);
1095 }
1096
1097
1098 bool
1099 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
1100 {
1101   if (!type_check (y, 0, BT_REAL))
1102     return false;
1103   if (!same_type_check (y, 0, x, 1))
1104     return false;
1105
1106   return true;
1107 }
1108
1109
1110 static bool
1111 gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no,
1112                   gfc_expr *stat, int stat_no)
1113 {
1114   if (!scalar_check (atom, atom_no) || !scalar_check (value, val_no))
1115     return false;
1116
1117   if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
1118       && !(atom->ts.type == BT_LOGICAL
1119            && atom->ts.kind == gfc_atomic_logical_kind))
1120     {
1121       gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1122                  "integer of ATOMIC_INT_KIND or a logical of "
1123                  "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic);
1124       return false;
1125     }
1126
1127   if (!gfc_is_coarray (atom) && !gfc_is_coindexed (atom))
1128     {
1129       gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1130                  "coarray or coindexed", &atom->where, gfc_current_intrinsic);
1131       return false;
1132     }
1133
1134   if (atom->ts.type != value->ts.type)
1135     {
1136       gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
1137                  "type as %qs at %L", gfc_current_intrinsic_arg[val_no]->name,
1138                  gfc_current_intrinsic, &value->where,
1139                  gfc_current_intrinsic_arg[atom_no]->name, &atom->where);
1140       return false;
1141     }
1142
1143   if (stat != NULL)
1144     {
1145       if (!type_check (stat, stat_no, BT_INTEGER))
1146         return false;
1147       if (!scalar_check (stat, stat_no))
1148         return false;
1149       if (!variable_check (stat, stat_no, false))
1150         return false;
1151       if (!kind_value_check (stat, stat_no, gfc_default_integer_kind))
1152         return false;
1153
1154       if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L",
1155                            gfc_current_intrinsic, &stat->where))
1156         return false;
1157     }
1158
1159   return true;
1160 }
1161
1162
1163 bool
1164 gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value, gfc_expr *stat)
1165 {
1166   if (atom->expr_type == EXPR_FUNCTION
1167       && atom->value.function.isym
1168       && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
1169     atom = atom->value.function.actual->expr;
1170
1171   if (!gfc_check_vardef_context (atom, false, false, false, NULL))
1172     {
1173       gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1174                  "definable", gfc_current_intrinsic, &atom->where);
1175       return false;
1176     }
1177
1178   return gfc_check_atomic (atom, 0, value, 1, stat, 2);
1179 }
1180
1181
1182 bool
1183 gfc_check_atomic_op (gfc_expr *atom, gfc_expr *value, gfc_expr *stat)
1184 {
1185   if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind)
1186     {
1187       gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1188                  "integer of ATOMIC_INT_KIND", &atom->where,
1189                  gfc_current_intrinsic);
1190       return false;
1191     }
1192
1193   return gfc_check_atomic_def (atom, value, stat);
1194 }
1195
1196
1197 bool
1198 gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat)
1199 {
1200   if (atom->expr_type == EXPR_FUNCTION
1201       && atom->value.function.isym
1202       && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
1203     atom = atom->value.function.actual->expr;
1204
1205   if (!gfc_check_vardef_context (value, false, false, false, NULL))
1206     {
1207       gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1208                  "definable", gfc_current_intrinsic, &value->where);
1209       return false;
1210     }
1211
1212   return gfc_check_atomic (atom, 1, value, 0, stat, 2);
1213 }
1214
1215
1216 bool
1217 gfc_check_image_status (gfc_expr *image, gfc_expr *team)
1218 {
1219   /* IMAGE has to be a positive, scalar integer.  */
1220   if (!type_check (image, 0, BT_INTEGER) || !scalar_check (image, 0)
1221       || !positive_check (0, image))
1222     return false;
1223
1224   if (team)
1225     {
1226       gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1227                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1228                  &team->where);
1229       return false;
1230     }
1231   return true;
1232 }
1233
1234
1235 bool
1236 gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind)
1237 {
1238   if (team)
1239     {
1240       gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1241                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
1242                  &team->where);
1243       return false;
1244     }
1245
1246   if (kind)
1247     {
1248       int k;
1249
1250       if (!type_check (kind, 1, BT_INTEGER) || !scalar_check (kind, 1)
1251           || !positive_check (1, kind))
1252         return false;
1253
1254       /* Get the kind, reporting error on non-constant or overflow.  */
1255       gfc_current_locus = kind->where;
1256       if (gfc_extract_int (kind, &k, 1))
1257         return false;
1258       if (gfc_validate_kind (BT_INTEGER, k, true) == -1)
1259         {
1260           gfc_error ("%qs argument of %qs intrinsic at %L shall specify a "
1261                      "valid integer kind", gfc_current_intrinsic_arg[1]->name,
1262                      gfc_current_intrinsic, &kind->where);
1263           return false;
1264         }
1265     }
1266   return true;
1267 }
1268
1269
1270 bool
1271 gfc_check_get_team (gfc_expr *level)
1272 {
1273   if (level)
1274     {
1275       gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1276                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
1277                  &level->where);
1278       return false;
1279     }
1280   return true;
1281 }
1282
1283
1284 bool
1285 gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare,
1286                       gfc_expr *new_val,  gfc_expr *stat)
1287 {
1288   if (atom->expr_type == EXPR_FUNCTION
1289       && atom->value.function.isym
1290       && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
1291     atom = atom->value.function.actual->expr;
1292
1293   if (!gfc_check_atomic (atom, 0, new_val, 3, stat, 4))
1294     return false;
1295
1296   if (!scalar_check (old, 1) || !scalar_check (compare, 2))
1297     return false;
1298
1299   if (!same_type_check (atom, 0, old, 1))
1300     return false;
1301
1302   if (!same_type_check (atom, 0, compare, 2))
1303     return false;
1304
1305   if (!gfc_check_vardef_context (atom, false, false, false, NULL))
1306     {
1307       gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1308                  "definable", gfc_current_intrinsic, &atom->where);
1309       return false;
1310     }
1311
1312   if (!gfc_check_vardef_context (old, false, false, false, NULL))
1313     {
1314       gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1315                  "definable", gfc_current_intrinsic, &old->where);
1316       return false;
1317     }
1318
1319   return true;
1320 }
1321
1322 bool
1323 gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat)
1324 {
1325   if (event->ts.type != BT_DERIVED
1326       || event->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
1327       || event->ts.u.derived->intmod_sym_id != ISOFORTRAN_EVENT_TYPE)
1328     {
1329       gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
1330                  "shall be of type EVENT_TYPE", &event->where);
1331       return false;
1332     }
1333
1334   if (!scalar_check (event, 0))
1335     return false;
1336
1337   if (!gfc_check_vardef_context (count, false, false, false, NULL))
1338     {
1339       gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1340                  "shall be definable", &count->where);
1341       return false;
1342     }
1343
1344   if (!type_check (count, 1, BT_INTEGER))
1345     return false;
1346
1347   int i = gfc_validate_kind (BT_INTEGER, count->ts.kind, false);
1348   int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
1349
1350   if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range)
1351     {
1352       gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1353                  "shall have at least the range of the default integer",
1354                  &count->where);
1355       return false;
1356     }
1357
1358   if (stat != NULL)
1359     {
1360       if (!type_check (stat, 2, BT_INTEGER))
1361         return false;
1362       if (!scalar_check (stat, 2))
1363         return false;
1364       if (!variable_check (stat, 2, false))
1365         return false;
1366
1367       if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L",
1368                            gfc_current_intrinsic, &stat->where))
1369         return false;
1370     }
1371
1372   return true;
1373 }
1374
1375
1376 bool
1377 gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old,
1378                            gfc_expr *stat)
1379 {
1380   if (atom->expr_type == EXPR_FUNCTION
1381       && atom->value.function.isym
1382       && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
1383     atom = atom->value.function.actual->expr;
1384
1385   if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind)
1386     {
1387       gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1388                  "integer of ATOMIC_INT_KIND", &atom->where,
1389                  gfc_current_intrinsic);
1390       return false;
1391     }
1392
1393   if (!gfc_check_atomic (atom, 0, value, 1, stat, 3))
1394     return false;
1395
1396   if (!scalar_check (old, 2))
1397     return false;
1398
1399   if (!same_type_check (atom, 0, old, 2))
1400     return false;
1401
1402   if (!gfc_check_vardef_context (atom, false, false, false, NULL))
1403     {
1404       gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1405                  "definable", gfc_current_intrinsic, &atom->where);
1406       return false;
1407     }
1408
1409   if (!gfc_check_vardef_context (old, false, false, false, NULL))
1410     {
1411       gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1412                  "definable", gfc_current_intrinsic, &old->where);
1413       return false;
1414     }
1415
1416   return true;
1417 }
1418
1419
1420 /* BESJN and BESYN functions.  */
1421
1422 bool
1423 gfc_check_besn (gfc_expr *n, gfc_expr *x)
1424 {
1425   if (!type_check (n, 0, BT_INTEGER))
1426     return false;
1427   if (n->expr_type == EXPR_CONSTANT)
1428     {
1429       int i;
1430       gfc_extract_int (n, &i);
1431       if (i < 0 && !gfc_notify_std (GFC_STD_GNU, "Negative argument "
1432                                     "N at %L", &n->where))
1433         return false;
1434     }
1435
1436   if (!type_check (x, 1, BT_REAL))
1437     return false;
1438
1439   return true;
1440 }
1441
1442
1443 /* Transformational version of the Bessel JN and YN functions.  */
1444
1445 bool
1446 gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
1447 {
1448   if (!type_check (n1, 0, BT_INTEGER))
1449     return false;
1450   if (!scalar_check (n1, 0))
1451     return false;
1452   if (!nonnegative_check ("N1", n1))
1453     return false;
1454
1455   if (!type_check (n2, 1, BT_INTEGER))
1456     return false;
1457   if (!scalar_check (n2, 1))
1458     return false;
1459   if (!nonnegative_check ("N2", n2))
1460     return false;
1461
1462   if (!type_check (x, 2, BT_REAL))
1463     return false;
1464   if (!scalar_check (x, 2))
1465     return false;
1466
1467   return true;
1468 }
1469
1470
1471 bool
1472 gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
1473 {
1474   if (!type_check (i, 0, BT_INTEGER))
1475     return false;
1476
1477   if (!type_check (j, 1, BT_INTEGER))
1478     return false;
1479
1480   return true;
1481 }
1482
1483
1484 bool
1485 gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
1486 {
1487   if (!type_check (i, 0, BT_INTEGER))
1488     return false;
1489
1490   if (!type_check (pos, 1, BT_INTEGER))
1491     return false;
1492
1493   if (!nonnegative_check ("pos", pos))
1494     return false;
1495
1496   if (!less_than_bitsize1 ("i", i, "pos", pos, false))
1497     return false;
1498
1499   return true;
1500 }
1501
1502
1503 bool
1504 gfc_check_char (gfc_expr *i, gfc_expr *kind)
1505 {
1506   if (!type_check (i, 0, BT_INTEGER))
1507     return false;
1508   if (!kind_check (kind, 1, BT_CHARACTER))
1509     return false;
1510
1511   return true;
1512 }
1513
1514
1515 bool
1516 gfc_check_chdir (gfc_expr *dir)
1517 {
1518   if (!type_check (dir, 0, BT_CHARACTER))
1519     return false;
1520   if (!kind_value_check (dir, 0, gfc_default_character_kind))
1521     return false;
1522
1523   return true;
1524 }
1525
1526
1527 bool
1528 gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
1529 {
1530   if (!type_check (dir, 0, BT_CHARACTER))
1531     return false;
1532   if (!kind_value_check (dir, 0, gfc_default_character_kind))
1533     return false;
1534
1535   if (status == NULL)
1536     return true;
1537
1538   if (!type_check (status, 1, BT_INTEGER))
1539     return false;
1540   if (!scalar_check (status, 1))
1541     return false;
1542
1543   return true;
1544 }
1545
1546
1547 bool
1548 gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
1549 {
1550   if (!type_check (name, 0, BT_CHARACTER))
1551     return false;
1552   if (!kind_value_check (name, 0, gfc_default_character_kind))
1553     return false;
1554
1555   if (!type_check (mode, 1, BT_CHARACTER))
1556     return false;
1557   if (!kind_value_check (mode, 1, gfc_default_character_kind))
1558     return false;
1559
1560   return true;
1561 }
1562
1563
1564 bool
1565 gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
1566 {
1567   if (!type_check (name, 0, BT_CHARACTER))
1568     return false;
1569   if (!kind_value_check (name, 0, gfc_default_character_kind))
1570     return false;
1571
1572   if (!type_check (mode, 1, BT_CHARACTER))
1573     return false;
1574   if (!kind_value_check (mode, 1, gfc_default_character_kind))
1575     return false;
1576
1577   if (status == NULL)
1578     return true;
1579
1580   if (!type_check (status, 2, BT_INTEGER))
1581     return false;
1582
1583   if (!scalar_check (status, 2))
1584     return false;
1585
1586   return true;
1587 }
1588
1589
1590 bool
1591 gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
1592 {
1593   if (!numeric_check (x, 0))
1594     return false;
1595
1596   if (y != NULL)
1597     {
1598       if (!numeric_check (y, 1))
1599         return false;
1600
1601       if (x->ts.type == BT_COMPLEX)
1602         {
1603           gfc_error ("%qs argument of %qs intrinsic at %L must not be "
1604                      "present if %<x%> is COMPLEX",
1605                      gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1606                      &y->where);
1607           return false;
1608         }
1609
1610       if (y->ts.type == BT_COMPLEX)
1611         {
1612           gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
1613                      "of either REAL or INTEGER",
1614                      gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1615                      &y->where);
1616           return false;
1617         }
1618
1619     }
1620
1621   if (!kind_check (kind, 2, BT_COMPLEX))
1622     return false;
1623
1624   if (!kind && warn_conversion
1625       && x->ts.type == BT_REAL && x->ts.kind > gfc_default_real_kind)
1626     gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind "
1627                      "COMPLEX(%d) at %L might lose precision, consider using "
1628                      "the KIND argument", gfc_typename (&x->ts),
1629                      gfc_default_real_kind, &x->where);
1630   else if (y && !kind && warn_conversion
1631            && y->ts.type == BT_REAL && y->ts.kind > gfc_default_real_kind)
1632     gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind "
1633                      "COMPLEX(%d) at %L might lose precision, consider using "
1634                      "the KIND argument", gfc_typename (&y->ts),
1635                      gfc_default_real_kind, &y->where);
1636   return true;
1637 }
1638
1639
1640 static bool
1641 check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat,
1642                     gfc_expr *errmsg, bool co_reduce)
1643 {
1644   if (!variable_check (a, 0, false))
1645     return false;
1646
1647   if (!gfc_check_vardef_context (a, false, false, false, "argument 'A' with "
1648                                  "INTENT(INOUT)"))
1649     return false;
1650
1651   /* Fortran 2008, 12.5.2.4, paragraph 18.  */
1652   if (gfc_has_vector_subscript (a))
1653     {
1654       gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
1655                  "subroutine %s shall not have a vector subscript",
1656                  &a->where, gfc_current_intrinsic);
1657       return false;
1658     }
1659
1660   if (gfc_is_coindexed (a))
1661     {
1662       gfc_error ("The A argument at %L to the intrinsic %s shall not be "
1663                  "coindexed", &a->where, gfc_current_intrinsic);
1664       return false;
1665     }
1666
1667   if (image_idx != NULL)
1668     {
1669       if (!type_check (image_idx, co_reduce ? 2 : 1, BT_INTEGER))
1670         return false;
1671       if (!scalar_check (image_idx, co_reduce ? 2 : 1))
1672         return false;
1673     }
1674
1675   if (stat != NULL)
1676     {
1677       if (!type_check (stat, co_reduce ? 3 : 2, BT_INTEGER))
1678         return false;
1679       if (!scalar_check (stat, co_reduce ? 3 : 2))
1680         return false;
1681       if (!variable_check (stat, co_reduce ? 3 : 2, false))
1682         return false;
1683       if (stat->ts.kind != 4)
1684         {
1685           gfc_error ("The stat= argument at %L must be a kind=4 integer "
1686                      "variable", &stat->where);
1687           return false;
1688         }
1689     }
1690
1691   if (errmsg != NULL)
1692     {
1693       if (!type_check (errmsg, co_reduce ? 4 : 3, BT_CHARACTER))
1694         return false;
1695       if (!scalar_check (errmsg, co_reduce ? 4 : 3))
1696         return false;
1697       if (!variable_check (errmsg, co_reduce ? 4 : 3, false))
1698         return false;
1699       if (errmsg->ts.kind != 1)
1700         {
1701           gfc_error ("The errmsg= argument at %L must be a default-kind "
1702                      "character variable", &errmsg->where);
1703           return false;
1704         }
1705     }
1706
1707   if (flag_coarray == GFC_FCOARRAY_NONE)
1708     {
1709       gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
1710                        &a->where);
1711       return false;
1712     }
1713
1714   return true;
1715 }
1716
1717
1718 bool
1719 gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat,
1720                         gfc_expr *errmsg)
1721 {
1722   if (a->ts.type == BT_CLASS || gfc_expr_attr (a).alloc_comp)
1723     {
1724       gfc_error ("Support for the A argument at %L which is polymorphic A "
1725                  "argument or has allocatable components is not yet "
1726                  "implemented", &a->where);
1727       return false;
1728     }
1729   return check_co_collective (a, source_image, stat, errmsg, false);
1730 }
1731
1732
1733 bool
1734 gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
1735                      gfc_expr *stat, gfc_expr *errmsg)
1736 {
1737   symbol_attribute attr;
1738   gfc_formal_arglist *formal;
1739   gfc_symbol *sym;
1740
1741   if (a->ts.type == BT_CLASS)
1742     {
1743       gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
1744                  &a->where);
1745       return false;
1746     }
1747
1748   if (gfc_expr_attr (a).alloc_comp)
1749     {
1750       gfc_error ("Support for the A argument at %L with allocatable components"
1751                  " is not yet implemented", &a->where);
1752       return false;
1753     }
1754
1755   if (!check_co_collective (a, result_image, stat, errmsg, true))
1756     return false;
1757
1758   if (!gfc_resolve_expr (op))
1759     return false;
1760
1761   attr = gfc_expr_attr (op);
1762   if (!attr.pure || !attr.function)
1763     {
1764       gfc_error ("OPERATOR argument at %L must be a PURE function",
1765                  &op->where);
1766       return false;
1767     }
1768
1769   if (attr.intrinsic)
1770     {
1771       /* None of the intrinsics fulfills the criteria of taking two arguments,
1772          returning the same type and kind as the arguments and being permitted
1773          as actual argument.  */
1774       gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
1775                  op->symtree->n.sym->name, &op->where);
1776       return false;
1777     }
1778
1779   if (gfc_is_proc_ptr_comp (op))
1780     {
1781       gfc_component *comp = gfc_get_proc_ptr_comp (op);
1782       sym = comp->ts.interface;
1783     }
1784   else
1785     sym = op->symtree->n.sym;
1786
1787   formal = sym->formal;
1788
1789   if (!formal || !formal->next || formal->next->next)
1790     {
1791       gfc_error ("The function passed as OPERATOR at %L shall have two "
1792                  "arguments", &op->where);
1793       return false;
1794     }
1795
1796   if (sym->result->ts.type == BT_UNKNOWN)
1797     gfc_set_default_type (sym->result, 0, NULL);
1798
1799   if (!gfc_compare_types (&a->ts, &sym->result->ts))
1800     {
1801       gfc_error ("The A argument at %L has type %s but the function passed as "
1802                  "OPERATOR at %L returns %s",
1803                  &a->where, gfc_typename (&a->ts), &op->where,
1804                  gfc_typename (&sym->result->ts));
1805       return false;
1806     }
1807   if (!gfc_compare_types (&a->ts, &formal->sym->ts)
1808       || !gfc_compare_types (&a->ts, &formal->next->sym->ts))
1809     {
1810       gfc_error ("The function passed as OPERATOR at %L has arguments of type "
1811                  "%s and %s but shall have type %s", &op->where,
1812                  gfc_typename (&formal->sym->ts),
1813                  gfc_typename (&formal->next->sym->ts), gfc_typename (&a->ts));
1814       return false;
1815     }
1816   if (op->rank || attr.allocatable || attr.pointer || formal->sym->as
1817       || formal->next->sym->as || formal->sym->attr.allocatable
1818       || formal->next->sym->attr.allocatable || formal->sym->attr.pointer
1819       || formal->next->sym->attr.pointer)
1820     {
1821       gfc_error ("The function passed as OPERATOR at %L shall have scalar "
1822                  "nonallocatable nonpointer arguments and return a "
1823                  "nonallocatable nonpointer scalar", &op->where);
1824       return false;
1825     }
1826
1827   if (formal->sym->attr.value != formal->next->sym->attr.value)
1828     {
1829       gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
1830                  "attribute either for none or both arguments", &op->where);
1831       return false;
1832     }
1833
1834   if (formal->sym->attr.target != formal->next->sym->attr.target)
1835     {
1836       gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
1837                  "attribute either for none or both arguments", &op->where);
1838       return false;
1839     }
1840
1841   if (formal->sym->attr.asynchronous != formal->next->sym->attr.asynchronous)
1842     {
1843       gfc_error ("The function passed as OPERATOR at %L shall have the "
1844                  "ASYNCHRONOUS attribute either for none or both arguments",
1845                  &op->where);
1846       return false;
1847     }
1848
1849   if (formal->sym->attr.optional || formal->next->sym->attr.optional)
1850     {
1851       gfc_error ("The function passed as OPERATOR at %L shall not have the "
1852                  "OPTIONAL attribute for either of the arguments", &op->where);
1853       return false;
1854     }
1855
1856   if (a->ts.type == BT_CHARACTER)
1857     {
1858       gfc_charlen *cl;
1859       unsigned long actual_size, formal_size1, formal_size2, result_size;
1860
1861       cl = a->ts.u.cl;
1862       actual_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
1863                      ? mpz_get_ui (cl->length->value.integer) : 0;
1864
1865       cl = formal->sym->ts.u.cl;
1866       formal_size1 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
1867                      ? mpz_get_ui (cl->length->value.integer) : 0;
1868
1869       cl = formal->next->sym->ts.u.cl;
1870       formal_size2 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
1871                      ? mpz_get_ui (cl->length->value.integer) : 0;
1872
1873       cl = sym->ts.u.cl;
1874       result_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
1875                     ? mpz_get_ui (cl->length->value.integer) : 0;
1876
1877       if (actual_size
1878           && ((formal_size1 && actual_size != formal_size1)
1879                || (formal_size2 && actual_size != formal_size2)))
1880         {
1881           gfc_error ("The character length of the A argument at %L and of the "
1882                      "arguments of the OPERATOR at %L shall be the same",
1883                      &a->where, &op->where);
1884           return false;
1885         }
1886       if (actual_size && result_size && actual_size != result_size)
1887         {
1888           gfc_error ("The character length of the A argument at %L and of the "
1889                      "function result of the OPERATOR at %L shall be the same",
1890                      &a->where, &op->where);
1891           return false;
1892         }
1893     }
1894
1895   return true;
1896 }
1897
1898
1899 bool
1900 gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
1901                      gfc_expr *errmsg)
1902 {
1903   if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL
1904       && a->ts.type != BT_CHARACTER)
1905     {
1906        gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
1907                   "integer, real or character",
1908                   gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
1909                   &a->where);
1910        return false;
1911     }
1912   return check_co_collective (a, result_image, stat, errmsg, false);
1913 }
1914
1915
1916 bool
1917 gfc_check_co_sum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
1918                   gfc_expr *errmsg)
1919 {
1920   if (!numeric_check (a, 0))
1921     return false;
1922   return check_co_collective (a, result_image, stat, errmsg, false);
1923 }
1924
1925
1926 bool
1927 gfc_check_complex (gfc_expr *x, gfc_expr *y)
1928 {
1929   if (!int_or_real_check (x, 0))
1930     return false;
1931   if (!scalar_check (x, 0))
1932     return false;
1933
1934   if (!int_or_real_check (y, 1))
1935     return false;
1936   if (!scalar_check (y, 1))
1937     return false;
1938
1939   return true;
1940 }
1941
1942
1943 bool
1944 gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
1945 {
1946   if (!logical_array_check (mask, 0))
1947     return false;
1948   if (!dim_check (dim, 1, false))
1949     return false;
1950   if (!dim_rank_check (dim, mask, 0))
1951     return false;
1952   if (!kind_check (kind, 2, BT_INTEGER))
1953     return false;
1954   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
1955                                "with KIND argument at %L",
1956                                gfc_current_intrinsic, &kind->where))
1957     return false;
1958
1959   return true;
1960 }
1961
1962
1963 bool
1964 gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
1965 {
1966   if (!array_check (array, 0))
1967     return false;
1968
1969   if (!type_check (shift, 1, BT_INTEGER))
1970     return false;
1971
1972   if (!dim_check (dim, 2, true))
1973     return false;
1974
1975   if (!dim_rank_check (dim, array, false))
1976     return false;
1977
1978   if (array->rank == 1 || shift->rank == 0)
1979     {
1980       if (!scalar_check (shift, 1))
1981         return false;
1982     }
1983   else if (shift->rank == array->rank - 1)
1984     {
1985       int d;
1986       if (!dim)
1987         d = 1;
1988       else if (dim->expr_type == EXPR_CONSTANT)
1989         gfc_extract_int (dim, &d);
1990       else
1991         d = -1;
1992
1993       if (d > 0)
1994         {
1995           int i, j;
1996           for (i = 0, j = 0; i < array->rank; i++)
1997             if (i != d - 1)
1998               {
1999                 if (!identical_dimen_shape (array, i, shift, j))
2000                   {
2001                     gfc_error ("%qs argument of %qs intrinsic at %L has "
2002                                "invalid shape in dimension %d (%ld/%ld)",
2003                                gfc_current_intrinsic_arg[1]->name,
2004                                gfc_current_intrinsic, &shift->where, i + 1,
2005                                mpz_get_si (array->shape[i]),
2006                                mpz_get_si (shift->shape[j]));
2007                     return false;
2008                   }
2009
2010                 j += 1;
2011               }
2012         }
2013     }
2014   else
2015     {
2016       gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2017                  "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
2018                  gfc_current_intrinsic, &shift->where, array->rank - 1);
2019       return false;
2020     }
2021
2022   return true;
2023 }
2024
2025
2026 bool
2027 gfc_check_ctime (gfc_expr *time)
2028 {
2029   if (!scalar_check (time, 0))
2030     return false;
2031
2032   if (!type_check (time, 0, BT_INTEGER))
2033     return false;
2034
2035   return true;
2036 }
2037
2038
2039 bool gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
2040 {
2041   if (!double_check (y, 0) || !double_check (x, 1))
2042     return false;
2043
2044   return true;
2045 }
2046
2047 bool
2048 gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
2049 {
2050   if (!numeric_check (x, 0))
2051     return false;
2052
2053   if (y != NULL)
2054     {
2055       if (!numeric_check (y, 1))
2056         return false;
2057
2058       if (x->ts.type == BT_COMPLEX)
2059         {
2060           gfc_error ("%qs argument of %qs intrinsic at %L must not be "
2061                      "present if %<x%> is COMPLEX",
2062                      gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2063                      &y->where);
2064           return false;
2065         }
2066
2067       if (y->ts.type == BT_COMPLEX)
2068         {
2069           gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2070                      "of either REAL or INTEGER",
2071                      gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2072                      &y->where);
2073           return false;
2074         }
2075     }
2076
2077   return true;
2078 }
2079
2080
2081 bool
2082 gfc_check_dble (gfc_expr *x)
2083 {
2084   if (!numeric_check (x, 0))
2085     return false;
2086
2087   return true;
2088 }
2089
2090
2091 bool
2092 gfc_check_digits (gfc_expr *x)
2093 {
2094   if (!int_or_real_check (x, 0))
2095     return false;
2096
2097   return true;
2098 }
2099
2100
2101 bool
2102 gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
2103 {
2104   switch (vector_a->ts.type)
2105     {
2106     case BT_LOGICAL:
2107       if (!type_check (vector_b, 1, BT_LOGICAL))
2108         return false;
2109       break;
2110
2111     case BT_INTEGER:
2112     case BT_REAL:
2113     case BT_COMPLEX:
2114       if (!numeric_check (vector_b, 1))
2115         return false;
2116       break;
2117
2118     default:
2119       gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
2120                  "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
2121                  gfc_current_intrinsic, &vector_a->where);
2122       return false;
2123     }
2124
2125   if (!rank_check (vector_a, 0, 1))
2126     return false;
2127
2128   if (!rank_check (vector_b, 1, 1))
2129     return false;
2130
2131   if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
2132     {
2133       gfc_error ("Different shape for arguments %qs and %qs at %L for "
2134                  "intrinsic %<dot_product%>",
2135                  gfc_current_intrinsic_arg[0]->name,
2136                  gfc_current_intrinsic_arg[1]->name, &vector_a->where);
2137       return false;
2138     }
2139
2140   return true;
2141 }
2142
2143
2144 bool
2145 gfc_check_dprod (gfc_expr *x, gfc_expr *y)
2146 {
2147   if (!type_check (x, 0, BT_REAL)
2148       || !type_check (y, 1, BT_REAL))
2149     return false;
2150
2151   if (x->ts.kind != gfc_default_real_kind)
2152     {
2153       gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2154                  "real", gfc_current_intrinsic_arg[0]->name,
2155                  gfc_current_intrinsic, &x->where);
2156       return false;
2157     }
2158
2159   if (y->ts.kind != gfc_default_real_kind)
2160     {
2161       gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2162                  "real", gfc_current_intrinsic_arg[1]->name,
2163                  gfc_current_intrinsic, &y->where);
2164       return false;
2165     }
2166
2167   return true;
2168 }
2169
2170
2171 bool
2172 gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
2173 {
2174   if (!type_check (i, 0, BT_INTEGER))
2175     return false;
2176
2177   if (!type_check (j, 1, BT_INTEGER))
2178     return false;
2179
2180   if (i->is_boz && j->is_boz)
2181     {
2182       gfc_error ("%<I%> at %L and %<J%>' at %L cannot both be BOZ literal "
2183                    "constants", &i->where, &j->where);
2184       return false;
2185     }
2186
2187   if (!i->is_boz && !j->is_boz && !same_type_check (i, 0, j, 1))
2188     return false;
2189
2190   if (!type_check (shift, 2, BT_INTEGER))
2191     return false;
2192
2193   if (!nonnegative_check ("SHIFT", shift))
2194     return false;
2195
2196   if (i->is_boz)
2197     {
2198       if (!less_than_bitsize1 ("J", j, "SHIFT", shift, true))
2199         return false;
2200       i->ts.kind = j->ts.kind;
2201     }
2202   else
2203     {
2204       if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
2205         return false;
2206       j->ts.kind = i->ts.kind;
2207     }
2208
2209   return true;
2210 }
2211
2212
2213 bool
2214 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
2215                    gfc_expr *dim)
2216 {
2217   int d;
2218
2219   if (!array_check (array, 0))
2220     return false;
2221
2222   if (!type_check (shift, 1, BT_INTEGER))
2223     return false;
2224
2225   if (!dim_check (dim, 3, true))
2226     return false;
2227
2228   if (!dim_rank_check (dim, array, false))
2229     return false;
2230
2231   if (!dim)
2232     d = 1;
2233   else if (dim->expr_type == EXPR_CONSTANT)
2234     gfc_extract_int (dim, &d);
2235   else
2236     d = -1;
2237
2238   if (array->rank == 1 || shift->rank == 0)
2239     {
2240       if (!scalar_check (shift, 1))
2241         return false;
2242     }
2243   else if (shift->rank == array->rank - 1)
2244     {
2245       if (d > 0)
2246         {
2247           int i, j;
2248           for (i = 0, j = 0; i < array->rank; i++)
2249             if (i != d - 1)
2250               {
2251                 if (!identical_dimen_shape (array, i, shift, j))
2252                   {
2253                     gfc_error ("%qs argument of %qs intrinsic at %L has "
2254                                "invalid shape in dimension %d (%ld/%ld)",
2255                                gfc_current_intrinsic_arg[1]->name,
2256                                gfc_current_intrinsic, &shift->where, i + 1,
2257                                mpz_get_si (array->shape[i]),
2258                                mpz_get_si (shift->shape[j]));
2259                     return false;
2260                   }
2261
2262                 j += 1;
2263               }
2264         }
2265     }
2266   else
2267     {
2268       gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2269                  "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
2270                  gfc_current_intrinsic, &shift->where, array->rank - 1);
2271       return false;
2272     }
2273
2274   if (boundary != NULL)
2275     {
2276       if (!same_type_check (array, 0, boundary, 2))
2277         return false;
2278
2279       /* Reject unequal string lengths and emit a better error message than
2280        gfc_check_same_strlen would.  */
2281       if (array->ts.type == BT_CHARACTER)
2282         {
2283           ssize_t len_a, len_b;
2284
2285           len_a = gfc_var_strlen (array);
2286           len_b = gfc_var_strlen (boundary);
2287           if (len_a != -1 && len_b != -1 && len_a != len_b)
2288             {
2289               gfc_error ("%qs must be of same type and kind as %qs at %L in %qs",
2290                          gfc_current_intrinsic_arg[2]->name,
2291                          gfc_current_intrinsic_arg[0]->name,
2292                          &boundary->where, gfc_current_intrinsic);
2293               return false;
2294             }
2295         }
2296
2297       if (array->rank == 1 || boundary->rank == 0)
2298         {
2299           if (!scalar_check (boundary, 2))
2300             return false;
2301         }
2302       else if (boundary->rank == array->rank - 1)
2303         {
2304           if (d > 0)
2305             {
2306               int i,j;
2307               for (i = 0, j = 0; i < array->rank; i++)
2308                 {
2309                   if (i != d - 1)
2310                     {
2311                       if (!identical_dimen_shape (array, i, boundary, j))
2312                         {
2313                           gfc_error ("%qs argument of %qs intrinsic at %L has "
2314                                      "invalid shape in dimension %d (%ld/%ld)",
2315                                      gfc_current_intrinsic_arg[2]->name,
2316                                      gfc_current_intrinsic, &shift->where, i+1,
2317                                      mpz_get_si (array->shape[i]),
2318                                      mpz_get_si (boundary->shape[j]));
2319                           return false;
2320                         }
2321                       j += 1;
2322                     }
2323                 }
2324             }
2325         }
2326       else
2327         {
2328           gfc_error ("%qs argument of intrinsic %qs at %L of must have "
2329                      "rank %d or be a scalar",
2330                      gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2331                      &shift->where, array->rank - 1);
2332           return false;
2333         }
2334     }
2335   else
2336     {
2337       switch (array->ts.type)
2338         {
2339         case BT_INTEGER:
2340         case BT_LOGICAL:
2341         case BT_REAL:
2342         case BT_COMPLEX:
2343         case BT_CHARACTER:
2344           break;
2345
2346         default:
2347           gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs "
2348                      "of type %qs", gfc_current_intrinsic_arg[2]->name,
2349                      gfc_current_intrinsic, &array->where,
2350                      gfc_current_intrinsic_arg[0]->name,
2351                      gfc_typename (&array->ts));
2352           return false;
2353         }
2354     }
2355
2356   return true;
2357 }
2358
2359 bool
2360 gfc_check_float (gfc_expr *a)
2361 {
2362   if (!type_check (a, 0, BT_INTEGER))
2363     return false;
2364
2365   if ((a->ts.kind != gfc_default_integer_kind)
2366       && !gfc_notify_std (GFC_STD_GNU, "non-default INTEGER "
2367                           "kind argument to %s intrinsic at %L",
2368                           gfc_current_intrinsic, &a->where))
2369     return false;
2370
2371   return true;
2372 }
2373
2374 /* A single complex argument.  */
2375
2376 bool
2377 gfc_check_fn_c (gfc_expr *a)
2378 {
2379   if (!type_check (a, 0, BT_COMPLEX))
2380     return false;
2381
2382   return true;
2383 }
2384
2385
2386 /* A single real argument.  */
2387
2388 bool
2389 gfc_check_fn_r (gfc_expr *a)
2390 {
2391   if (!type_check (a, 0, BT_REAL))
2392     return false;
2393
2394   return true;
2395 }
2396
2397 /* A single double argument.  */
2398
2399 bool
2400 gfc_check_fn_d (gfc_expr *a)
2401 {
2402   if (!double_check (a, 0))
2403     return false;
2404
2405   return true;
2406 }
2407
2408 /* A single real or complex argument.  */
2409
2410 bool
2411 gfc_check_fn_rc (gfc_expr *a)
2412 {
2413   if (!real_or_complex_check (a, 0))
2414     return false;
2415
2416   return true;
2417 }
2418
2419
2420 bool
2421 gfc_check_fn_rc2008 (gfc_expr *a)
2422 {
2423   if (!real_or_complex_check (a, 0))
2424     return false;
2425
2426   if (a->ts.type == BT_COMPLEX
2427       && !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument %qs "
2428                           "of %qs intrinsic at %L",
2429                           gfc_current_intrinsic_arg[0]->name,
2430                           gfc_current_intrinsic, &a->where))
2431     return false;
2432
2433   return true;
2434 }
2435
2436
2437 bool
2438 gfc_check_fnum (gfc_expr *unit)
2439 {
2440   if (!type_check (unit, 0, BT_INTEGER))
2441     return false;
2442
2443   if (!scalar_check (unit, 0))
2444     return false;
2445
2446   return true;
2447 }
2448
2449
2450 bool
2451 gfc_check_huge (gfc_expr *x)
2452 {
2453   if (!int_or_real_check (x, 0))
2454     return false;
2455
2456   return true;
2457 }
2458
2459
2460 bool
2461 gfc_check_hypot (gfc_expr *x, gfc_expr *y)
2462 {
2463   if (!type_check (x, 0, BT_REAL))
2464     return false;
2465   if (!same_type_check (x, 0, y, 1))
2466     return false;
2467
2468   return true;
2469 }
2470
2471
2472 /* Check that the single argument is an integer.  */
2473
2474 bool
2475 gfc_check_i (gfc_expr *i)
2476 {
2477   if (!type_check (i, 0, BT_INTEGER))
2478     return false;
2479
2480   return true;
2481 }
2482
2483
2484 bool
2485 gfc_check_iand (gfc_expr *i, gfc_expr *j)
2486 {
2487   if (!type_check (i, 0, BT_INTEGER))
2488     return false;
2489
2490   if (!type_check (j, 1, BT_INTEGER))
2491     return false;
2492
2493   if (i->ts.kind != j->ts.kind)
2494     {
2495       if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
2496                            &i->where))
2497         return false;
2498     }
2499
2500   return true;
2501 }
2502
2503
2504 bool
2505 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
2506 {
2507   if (!type_check (i, 0, BT_INTEGER))
2508     return false;
2509
2510   if (!type_check (pos, 1, BT_INTEGER))
2511     return false;
2512
2513   if (!type_check (len, 2, BT_INTEGER))
2514     return false;
2515
2516   if (!nonnegative_check ("pos", pos))
2517     return false;
2518
2519   if (!nonnegative_check ("len", len))
2520     return false;
2521
2522   if (!less_than_bitsize2 ("i", i, "pos", pos, "len", len))
2523     return false;
2524
2525   return true;
2526 }
2527
2528
2529 bool
2530 gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
2531 {
2532   int i;
2533
2534   if (!type_check (c, 0, BT_CHARACTER))
2535     return false;
2536
2537   if (!kind_check (kind, 1, BT_INTEGER))
2538     return false;
2539
2540   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
2541                                "with KIND argument at %L",
2542                                gfc_current_intrinsic, &kind->where))
2543     return false;
2544
2545   if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
2546     {
2547       gfc_expr *start;
2548       gfc_expr *end;
2549       gfc_ref *ref;
2550
2551       /* Substring references don't have the charlength set.  */
2552       ref = c->ref;
2553       while (ref && ref->type != REF_SUBSTRING)
2554         ref = ref->next;
2555
2556       gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
2557
2558       if (!ref)
2559         {
2560           /* Check that the argument is length one.  Non-constant lengths
2561              can't be checked here, so assume they are ok.  */
2562           if (c->ts.u.cl && c->ts.u.cl->length)
2563             {
2564               /* If we already have a length for this expression then use it.  */
2565               if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2566                 return true;
2567               i = mpz_get_si (c->ts.u.cl->length->value.integer);
2568             }
2569           else
2570             return true;
2571         }
2572       else
2573         {
2574           start = ref->u.ss.start;
2575           end = ref->u.ss.end;
2576
2577           gcc_assert (start);
2578           if (end == NULL || end->expr_type != EXPR_CONSTANT
2579               || start->expr_type != EXPR_CONSTANT)
2580             return true;
2581
2582           i = mpz_get_si (end->value.integer) + 1
2583             - mpz_get_si (start->value.integer);
2584         }
2585     }
2586   else
2587     return true;
2588
2589   if (i != 1)
2590     {
2591       gfc_error ("Argument of %s at %L must be of length one",
2592                  gfc_current_intrinsic, &c->where);
2593       return false;
2594     }
2595
2596   return true;
2597 }
2598
2599
2600 bool
2601 gfc_check_idnint (gfc_expr *a)
2602 {
2603   if (!double_check (a, 0))
2604     return false;
2605
2606   return true;
2607 }
2608
2609
2610 bool
2611 gfc_check_ieor (gfc_expr *i, gfc_expr *j)
2612 {
2613   if (!type_check (i, 0, BT_INTEGER))
2614     return false;
2615
2616   if (!type_check (j, 1, BT_INTEGER))
2617     return false;
2618
2619   if (i->ts.kind != j->ts.kind)
2620     {
2621       if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
2622                            &i->where))
2623         return false;
2624     }
2625
2626   return true;
2627 }
2628
2629
2630 bool
2631 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
2632                  gfc_expr *kind)
2633 {
2634   if (!type_check (string, 0, BT_CHARACTER)
2635       || !type_check (substring, 1, BT_CHARACTER))
2636     return false;
2637
2638   if (back != NULL && !type_check (back, 2, BT_LOGICAL))
2639     return false;
2640
2641   if (!kind_check (kind, 3, BT_INTEGER))
2642     return false;
2643   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
2644                                "with KIND argument at %L",
2645                                gfc_current_intrinsic, &kind->where))
2646     return false;
2647
2648   if (string->ts.kind != substring->ts.kind)
2649     {
2650       gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
2651                  "kind as %qs", gfc_current_intrinsic_arg[1]->name,
2652                  gfc_current_intrinsic, &substring->where,
2653                  gfc_current_intrinsic_arg[0]->name);
2654       return false;
2655     }
2656
2657   return true;
2658 }
2659
2660
2661 bool
2662 gfc_check_int (gfc_expr *x, gfc_expr *kind)
2663 {
2664   if (!numeric_check (x, 0))
2665     return false;
2666
2667   if (!kind_check (kind, 1, BT_INTEGER))
2668     return false;
2669
2670   return true;
2671 }
2672
2673
2674 bool
2675 gfc_check_intconv (gfc_expr *x)
2676 {
2677   if (!numeric_check (x, 0))
2678     return false;
2679
2680   return true;
2681 }
2682
2683
2684 bool
2685 gfc_check_ior (gfc_expr *i, gfc_expr *j)
2686 {
2687   if (!type_check (i, 0, BT_INTEGER))
2688     return false;
2689
2690   if (!type_check (j, 1, BT_INTEGER))
2691     return false;
2692
2693   if (i->ts.kind != j->ts.kind)
2694     {
2695       if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
2696                            &i->where))
2697         return false;
2698     }
2699
2700   return true;
2701 }
2702
2703
2704 bool
2705 gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
2706 {
2707   if (!type_check (i, 0, BT_INTEGER)
2708       || !type_check (shift, 1, BT_INTEGER))
2709     return false;
2710
2711   if (!less_than_bitsize1 ("I", i, NULL, shift, true))
2712     return false;
2713
2714   return true;
2715 }
2716
2717
2718 bool
2719 gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
2720 {
2721   if (!type_check (i, 0, BT_INTEGER)
2722       || !type_check (shift, 1, BT_INTEGER))
2723     return false;
2724
2725   if (size != NULL)
2726     {
2727       int i2, i3;
2728
2729       if (!type_check (size, 2, BT_INTEGER))
2730         return false;
2731
2732       if (!less_than_bitsize1 ("I", i, "SIZE", size, true))
2733         return false;
2734
2735       if (size->expr_type == EXPR_CONSTANT)
2736         {
2737           gfc_extract_int (size, &i3);
2738           if (i3 <= 0)
2739             {
2740               gfc_error ("SIZE at %L must be positive", &size->where);
2741               return false;
2742             }
2743
2744           if (shift->expr_type == EXPR_CONSTANT)
2745             {
2746               gfc_extract_int (shift, &i2);
2747               if (i2 < 0)
2748                 i2 = -i2;
2749
2750               if (i2 > i3)
2751                 {
2752                   gfc_error ("The absolute value of SHIFT at %L must be less "
2753                              "than or equal to SIZE at %L", &shift->where,
2754                              &size->where);
2755                   return false;
2756                 }
2757              }
2758         }
2759     }
2760   else if (!less_than_bitsize1 ("I", i, NULL, shift, true))
2761     return false;
2762
2763   return true;
2764 }
2765
2766
2767 bool
2768 gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
2769 {
2770   if (!type_check (pid, 0, BT_INTEGER))
2771     return false;
2772
2773   if (!scalar_check (pid, 0))
2774     return false;
2775
2776   if (!type_check (sig, 1, BT_INTEGER))
2777     return false;
2778
2779   if (!scalar_check (sig, 1))
2780     return false;
2781
2782   return true;
2783 }
2784
2785
2786 bool
2787 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
2788 {
2789   if (!type_check (pid, 0, BT_INTEGER))
2790     return false;
2791
2792   if (!scalar_check (pid, 0))
2793     return false;
2794
2795   if (!type_check (sig, 1, BT_INTEGER))
2796     return false;
2797
2798   if (!scalar_check (sig, 1))
2799     return false;
2800
2801   if (status)
2802     {
2803       if (!type_check (status, 2, BT_INTEGER))
2804         return false;
2805
2806       if (!scalar_check (status, 2))
2807         return false;
2808     }
2809
2810   return true;
2811 }
2812
2813
2814 bool
2815 gfc_check_kind (gfc_expr *x)
2816 {
2817   if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS)
2818     {
2819       gfc_error ("%qs argument of %qs intrinsic at %L must be of "
2820                  "intrinsic type", gfc_current_intrinsic_arg[0]->name,
2821                  gfc_current_intrinsic, &x->where);
2822       return false;
2823     }
2824   if (x->ts.type == BT_PROCEDURE)
2825     {
2826       gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
2827                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
2828                  &x->where);
2829       return false;
2830     }
2831
2832   return true;
2833 }
2834
2835
2836 bool
2837 gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2838 {
2839   if (!array_check (array, 0))
2840     return false;
2841
2842   if (!dim_check (dim, 1, false))
2843     return false;
2844
2845   if (!dim_rank_check (dim, array, 1))
2846     return false;
2847
2848   if (!kind_check (kind, 2, BT_INTEGER))
2849     return false;
2850   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
2851                                "with KIND argument at %L",
2852                                gfc_current_intrinsic, &kind->where))
2853     return false;
2854
2855   return true;
2856 }
2857
2858
2859 bool
2860 gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
2861 {
2862   if (flag_coarray == GFC_FCOARRAY_NONE)
2863     {
2864       gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2865       return false;
2866     }
2867
2868   if (!coarray_check (coarray, 0))
2869     return false;
2870
2871   if (dim != NULL)
2872     {
2873       if (!dim_check (dim, 1, false))
2874         return false;
2875
2876       if (!dim_corank_check (dim, coarray))
2877         return false;
2878     }
2879
2880   if (!kind_check (kind, 2, BT_INTEGER))
2881     return false;
2882
2883   return true;
2884 }
2885
2886
2887 bool
2888 gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
2889 {
2890   if (!type_check (s, 0, BT_CHARACTER))
2891     return false;
2892
2893   if (!kind_check (kind, 1, BT_INTEGER))
2894     return false;
2895   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
2896                                "with KIND argument at %L",
2897                                gfc_current_intrinsic, &kind->where))
2898     return false;
2899
2900   return true;
2901 }
2902
2903
2904 bool
2905 gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
2906 {
2907   if (!type_check (a, 0, BT_CHARACTER))
2908     return false;
2909   if (!kind_value_check (a, 0, gfc_default_character_kind))
2910     return false;
2911
2912   if (!type_check (b, 1, BT_CHARACTER))
2913     return false;
2914   if (!kind_value_check (b, 1, gfc_default_character_kind))
2915     return false;
2916
2917   return true;
2918 }
2919
2920
2921 bool
2922 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
2923 {
2924   if (!type_check (path1, 0, BT_CHARACTER))
2925     return false;
2926   if (!kind_value_check (path1, 0, gfc_default_character_kind))
2927     return false;
2928
2929   if (!type_check (path2, 1, BT_CHARACTER))
2930     return false;
2931   if (!kind_value_check (path2, 1, gfc_default_character_kind))
2932     return false;
2933
2934   return true;
2935 }
2936
2937
2938 bool
2939 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2940 {
2941   if (!type_check (path1, 0, BT_CHARACTER))
2942     return false;
2943   if (!kind_value_check (path1, 0, gfc_default_character_kind))
2944     return false;
2945
2946   if (!type_check (path2, 1, BT_CHARACTER))
2947     return false;
2948   if (!kind_value_check (path2, 0, gfc_default_character_kind))
2949     return false;
2950
2951   if (status == NULL)
2952     return true;
2953
2954   if (!type_check (status, 2, BT_INTEGER))
2955     return false;
2956
2957   if (!scalar_check (status, 2))
2958     return false;
2959
2960   return true;
2961 }
2962
2963
2964 bool
2965 gfc_check_loc (gfc_expr *expr)
2966 {
2967   return variable_check (expr, 0, true);
2968 }
2969
2970
2971 bool
2972 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
2973 {
2974   if (!type_check (path1, 0, BT_CHARACTER))
2975     return false;
2976   if (!kind_value_check (path1, 0, gfc_default_character_kind))
2977     return false;
2978
2979   if (!type_check (path2, 1, BT_CHARACTER))
2980     return false;
2981   if (!kind_value_check (path2, 1, gfc_default_character_kind))
2982     return false;
2983
2984   return true;
2985 }
2986
2987
2988 bool
2989 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2990 {
2991   if (!type_check (path1, 0, BT_CHARACTER))
2992     return false;
2993   if (!kind_value_check (path1, 0, gfc_default_character_kind))
2994     return false;
2995
2996   if (!type_check (path2, 1, BT_CHARACTER))
2997     return false;
2998   if (!kind_value_check (path2, 1, gfc_default_character_kind))
2999     return false;
3000
3001   if (status == NULL)
3002     return true;
3003
3004   if (!type_check (status, 2, BT_INTEGER))
3005     return false;
3006
3007   if (!scalar_check (status, 2))
3008     return false;
3009
3010   return true;
3011 }
3012
3013
3014 bool
3015 gfc_check_logical (gfc_expr *a, gfc_expr *kind)
3016 {
3017   if (!type_check (a, 0, BT_LOGICAL))
3018     return false;
3019   if (!kind_check (kind, 1, BT_LOGICAL))
3020     return false;
3021
3022   return true;
3023 }
3024
3025
3026 /* Min/max family.  */
3027
3028 static bool
3029 min_max_args (gfc_actual_arglist *args)
3030 {
3031   gfc_actual_arglist *arg;
3032   int i, j, nargs, *nlabels, nlabelless;
3033   bool a1 = false, a2 = false;
3034
3035   if (args == NULL || args->next == NULL)
3036     {
3037       gfc_error ("Intrinsic %qs at %L must have at least two arguments",
3038                  gfc_current_intrinsic, gfc_current_intrinsic_where);
3039       return false;
3040     }
3041
3042   if (!args->name)
3043     a1 = true;
3044
3045   if (!args->next->name)
3046     a2 = true;
3047
3048   nargs = 0;
3049   for (arg = args; arg; arg = arg->next)
3050     if (arg->name)
3051       nargs++;
3052
3053   if (nargs == 0)
3054     return true;
3055
3056   /* Note: Having a keywordless argument after an "arg=" is checked before.  */
3057   nlabelless = 0;
3058   nlabels = XALLOCAVEC (int, nargs);
3059   for (arg = args, i = 0; arg; arg = arg->next, i++)
3060     if (arg->name)
3061       {
3062         int n;
3063         char *endp;
3064
3065         if (arg->name[0] != 'a' || arg->name[1] < '1' || arg->name[1] > '9')
3066           goto unknown;
3067         n = strtol (&arg->name[1], &endp, 10);
3068         if (endp[0] != '\0')
3069           goto unknown;
3070         if (n <= 0)
3071           goto unknown;
3072         if (n <= nlabelless)
3073           goto duplicate;
3074         nlabels[i] = n;
3075         if (n == 1)
3076           a1 = true;
3077         if (n == 2)
3078           a2 = true;
3079       }
3080     else
3081       nlabelless++;
3082
3083   if (!a1 || !a2)
3084     {
3085       gfc_error ("Missing %qs argument to the %s intrinsic at %L",
3086                  !a1 ? "a1" : "a2", gfc_current_intrinsic,
3087                  gfc_current_intrinsic_where);
3088       return false;
3089     }
3090
3091   /* Check for duplicates.  */
3092   for (i = 0; i < nargs; i++)
3093     for (j = i + 1; j < nargs; j++)
3094       if (nlabels[i] == nlabels[j])
3095         goto duplicate;
3096
3097   return true;
3098
3099 duplicate:
3100   gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name,
3101              &arg->expr->where, gfc_current_intrinsic);
3102   return false;
3103
3104 unknown:
3105   gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name,
3106              &arg->expr->where, gfc_current_intrinsic);
3107   return false;
3108 }
3109
3110
3111 static bool
3112 check_rest (bt type, int kind, gfc_actual_arglist *arglist)
3113 {
3114   gfc_actual_arglist *arg, *tmp;
3115   gfc_expr *x;
3116   int m, n;
3117
3118   if (!min_max_args (arglist))
3119     return false;
3120
3121   for (arg = arglist, n=1; arg; arg = arg->next, n++)
3122     {
3123       x = arg->expr;
3124       if (x->ts.type != type || x->ts.kind != kind)
3125         {
3126           if (x->ts.type == type)
3127             {
3128               if (!gfc_notify_std (GFC_STD_GNU, "Different type "
3129                                    "kinds at %L", &x->where))
3130                 return false;
3131             }
3132           else
3133             {
3134               gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
3135                          "%s(%d)", n, gfc_current_intrinsic, &x->where,
3136                          gfc_basic_typename (type), kind);
3137               return false;
3138             }
3139         }
3140
3141       for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
3142         if (!gfc_check_conformance (tmp->expr, x,
3143                                     "arguments 'a%d' and 'a%d' for "
3144                                     "intrinsic '%s'", m, n,
3145                                     gfc_current_intrinsic))
3146             return false;
3147     }
3148
3149   return true;
3150 }
3151
3152
3153 bool
3154 gfc_check_min_max (gfc_actual_arglist *arg)
3155 {
3156   gfc_expr *x;
3157
3158   if (!min_max_args (arg))
3159     return false;
3160
3161   x = arg->expr;
3162
3163   if (x->ts.type == BT_CHARACTER)
3164     {
3165       if (!gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
3166                            "with CHARACTER argument at %L",
3167                            gfc_current_intrinsic, &x->where))
3168         return false;
3169     }
3170   else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
3171     {
3172       gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
3173                  "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
3174       return false;
3175     }
3176
3177   return check_rest (x->ts.type, x->ts.kind, arg);
3178 }
3179
3180
3181 bool
3182 gfc_check_min_max_integer (gfc_actual_arglist *arg)
3183 {
3184   return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
3185 }
3186
3187
3188 bool
3189 gfc_check_min_max_real (gfc_actual_arglist *arg)
3190 {
3191   return check_rest (BT_REAL, gfc_default_real_kind, arg);
3192 }
3193
3194
3195 bool
3196 gfc_check_min_max_double (gfc_actual_arglist *arg)
3197 {
3198   return check_rest (BT_REAL, gfc_default_double_kind, arg);
3199 }
3200
3201
3202 /* End of min/max family.  */
3203
3204 bool
3205 gfc_check_malloc (gfc_expr *size)
3206 {
3207   if (!type_check (size, 0, BT_INTEGER))
3208     return false;
3209
3210   if (!scalar_check (size, 0))
3211     return false;
3212
3213   return true;
3214 }
3215
3216
3217 bool
3218 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
3219 {
3220   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
3221     {
3222       gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3223                  "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
3224                  gfc_current_intrinsic, &matrix_a->where);
3225       return false;
3226     }
3227
3228   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
3229     {
3230       gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3231                  "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
3232                  gfc_current_intrinsic, &matrix_b->where);
3233       return false;
3234     }
3235
3236   if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
3237       || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
3238     {
3239       gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
3240                  gfc_current_intrinsic, &matrix_a->where,
3241                  gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
3242        return false;
3243     }
3244
3245   switch (matrix_a->rank)
3246     {
3247     case 1:
3248       if (!rank_check (matrix_b, 1, 2))
3249         return false;
3250       /* Check for case matrix_a has shape(m), matrix_b has shape (m, k).  */
3251       if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
3252         {
3253           gfc_error ("Different shape on dimension 1 for arguments %qs "
3254                      "and %qs at %L for intrinsic matmul",
3255                      gfc_current_intrinsic_arg[0]->name,
3256                      gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
3257           return false;
3258         }
3259       break;
3260
3261     case 2:
3262       if (matrix_b->rank != 2)
3263         {
3264           if (!rank_check (matrix_b, 1, 1))
3265             return false;
3266         }
3267       /* matrix_b has rank 1 or 2 here. Common check for the cases
3268          - matrix_a has shape (n,m) and matrix_b has shape (m, k)
3269          - matrix_a has shape (n,m) and matrix_b has shape (m).  */
3270       if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
3271         {
3272           gfc_error ("Different shape on dimension 2 for argument %qs and "
3273                      "dimension 1 for argument %qs at %L for intrinsic "
3274                      "matmul", gfc_current_intrinsic_arg[0]->name,
3275                      gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
3276           return false;
3277         }
3278       break;
3279
3280     default:
3281       gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
3282                  "1 or 2", gfc_current_intrinsic_arg[0]->name,
3283                  gfc_current_intrinsic, &matrix_a->where);
3284       return false;
3285     }
3286
3287   return true;
3288 }
3289
3290
3291 /* Whoever came up with this interface was probably on something.
3292    The possibilities for the occupation of the second and third
3293    parameters are:
3294
3295          Arg #2     Arg #3
3296          NULL       NULL
3297          DIM    NULL
3298          MASK       NULL
3299          NULL       MASK             minloc(array, mask=m)
3300          DIM    MASK
3301
3302    I.e. in the case of minloc(array,mask), mask will be in the second
3303    position of the argument list and we'll have to fix that up.  Also,
3304    add the BACK argument if that isn't present.  */
3305
3306 bool
3307 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
3308 {
3309   gfc_expr *a, *m, *d, *k, *b;
3310
3311   a = ap->expr;
3312   if (!int_or_real_or_char_check_f2003 (a, 0) || !array_check (a, 0))
3313     return false;
3314
3315   d = ap->next->expr;
3316   m = ap->next->next->expr;
3317   k = ap->next->next->next->expr;
3318   b = ap->next->next->next->next->expr;
3319
3320   if (b)
3321     {
3322       if (!type_check (b, 4, BT_LOGICAL) || !scalar_check (b,4))
3323         return false;
3324     }
3325   else
3326     {
3327       b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0);
3328       ap->next->next->next->next->expr = b;
3329     }
3330
3331   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
3332       && ap->next->name == NULL)
3333     {
3334       m = d;
3335       d = NULL;
3336       ap->next->expr = NULL;
3337       ap->next->next->expr = m;
3338     }
3339
3340   if (!dim_check (d, 1, false))
3341     return false;
3342
3343   if (!dim_rank_check (d, a, 0))
3344     return false;
3345
3346   if (m != NULL && !type_check (m, 2, BT_LOGICAL))
3347     return false;
3348
3349   if (m != NULL
3350       && !gfc_check_conformance (a, m,
3351                                  "arguments '%s' and '%s' for intrinsic %s",
3352                                  gfc_current_intrinsic_arg[0]->name,
3353                                  gfc_current_intrinsic_arg[2]->name,
3354                                  gfc_current_intrinsic))
3355     return false;
3356
3357   if (!kind_check (k, 1, BT_INTEGER))
3358     return false;
3359
3360   return true;
3361 }
3362
3363 /* Check function for findloc.  Mostly like gfc_check_minloc_maxloc
3364    above, with the additional "value" argument.  */
3365
3366 bool
3367 gfc_check_findloc (gfc_actual_arglist *ap)
3368 {
3369   gfc_expr *a, *v, *m, *d, *k, *b;
3370
3371   a = ap->expr;
3372   if (!intrinsic_type_check (a, 0) || !array_check (a, 0))
3373     return false;
3374
3375   v = ap->next->expr;
3376   if (!scalar_check (v,1))
3377     return false;
3378
3379   /* Check if the type is compatible.  */
3380
3381   if ((a->ts.type == BT_LOGICAL && v->ts.type != BT_LOGICAL)
3382       || (a->ts.type != BT_LOGICAL && v->ts.type == BT_LOGICAL))
3383     {
3384       gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
3385                  "conformance to argument %qs at %L",
3386                  gfc_current_intrinsic_arg[0]->name,
3387                  gfc_current_intrinsic, &a->where,
3388                  gfc_current_intrinsic_arg[1]->name, &v->where);
3389     }
3390
3391   d = ap->next->next->expr;
3392   m = ap->next->next->next->expr;
3393   k = ap->next->next->next->next->expr;
3394   b = ap->next->next->next->next->next->expr;
3395
3396   if (b)
3397     {
3398       if (!type_check (b, 5, BT_LOGICAL) || !scalar_check (b,4))
3399         return false;
3400     }
3401   else
3402     {
3403       b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0);
3404       ap->next->next->next->next->next->expr = b;
3405     }
3406
3407   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
3408       && ap->next->name == NULL)
3409     {
3410       m = d;
3411       d = NULL;
3412       ap->next->next->expr = NULL;
3413       ap->next->next->next->expr = m;
3414     }
3415
3416   if (!dim_check (d, 2, false))
3417     return false;
3418
3419   if (!dim_rank_check (d, a, 0))
3420     return false;
3421
3422   if (m != NULL && !type_check (m, 3, BT_LOGICAL))
3423     return false;
3424
3425   if (m != NULL
3426       && !gfc_check_conformance (a, m,
3427                                  "arguments '%s' and '%s' for intrinsic %s",
3428                                  gfc_current_intrinsic_arg[0]->name,
3429                                  gfc_current_intrinsic_arg[3]->name,
3430                                  gfc_current_intrinsic))
3431     return false;
3432
3433   if (!kind_check (k, 1, BT_INTEGER))
3434     return false;
3435
3436   return true;
3437 }
3438
3439
3440 /* Similar to minloc/maxloc, the argument list might need to be
3441    reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
3442    difference is that MINLOC/MAXLOC take an additional KIND argument.
3443    The possibilities are:
3444
3445          Arg #2     Arg #3
3446          NULL       NULL
3447          DIM    NULL
3448          MASK       NULL
3449          NULL       MASK             minval(array, mask=m)
3450          DIM    MASK
3451
3452    I.e. in the case of minval(array,mask), mask will be in the second
3453    position of the argument list and we'll have to fix that up.  */
3454
3455 static bool
3456 check_reduction (gfc_actual_arglist *ap)
3457 {
3458   gfc_expr *a, *m, *d;
3459
3460   a = ap->expr;
3461   d = ap->next->expr;
3462   m = ap->next->next->expr;
3463
3464   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
3465       && ap->next->name == NULL)
3466     {
3467       m = d;
3468       d = NULL;
3469       ap->next->expr = NULL;
3470       ap->next->next->expr = m;
3471     }
3472
3473   if (!dim_check (d, 1, false))
3474     return false;
3475
3476   if (!dim_rank_check (d, a, 0))
3477     return false;
3478
3479   if (m != NULL && !type_check (m, 2, BT_LOGICAL))
3480     return false;
3481
3482   if (m != NULL
3483       && !gfc_check_conformance (a, m,
3484                                  "arguments '%s' and '%s' for intrinsic %s",
3485                                  gfc_current_intrinsic_arg[0]->name,
3486                                  gfc_current_intrinsic_arg[2]->name,
3487                                  gfc_current_intrinsic))
3488     return false;
3489
3490   return true;
3491 }
3492
3493
3494 bool
3495 gfc_check_minval_maxval (gfc_actual_arglist *ap)
3496 {
3497   if (!int_or_real_or_char_check_f2003 (ap->expr, 0)
3498       || !array_check (ap->expr, 0))
3499     return false;
3500
3501   return check_reduction (ap);
3502 }
3503
3504
3505 bool
3506 gfc_check_product_sum (gfc_actual_arglist *ap)
3507 {
3508   if (!numeric_check (ap->expr, 0)
3509       || !array_check (ap->expr, 0))
3510     return false;
3511
3512   return check_reduction (ap);
3513 }
3514
3515
3516 /* For IANY, IALL and IPARITY.  */
3517
3518 bool
3519 gfc_check_mask (gfc_expr *i, gfc_expr *kind)
3520 {
3521   int k;
3522
3523   if (!type_check (i, 0, BT_INTEGER))
3524     return false;
3525
3526   if (!nonnegative_check ("I", i))
3527     return false;
3528
3529   if (!kind_check (kind, 1, BT_INTEGER))
3530     return false;
3531
3532   if (kind)
3533     gfc_extract_int (kind, &k);
3534   else
3535     k = gfc_default_integer_kind;
3536
3537   if (!less_than_bitsizekind ("I", i, k))
3538     return false;
3539
3540   return true;
3541 }
3542
3543
3544 bool
3545 gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
3546 {
3547   if (ap->expr->ts.type != BT_INTEGER)
3548     {
3549       gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
3550                  gfc_current_intrinsic_arg[0]->name,
3551                  gfc_current_intrinsic, &ap->expr->where);
3552       return false;
3553     }
3554
3555   if (!array_check (ap->expr, 0))
3556     return false;
3557
3558   return check_reduction (ap);
3559 }
3560
3561
3562 bool
3563 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
3564 {
3565   if (!same_type_check (tsource, 0, fsource, 1))
3566     return false;
3567
3568   if (!type_check (mask, 2, BT_LOGICAL))
3569     return false;
3570
3571   if (tsource->ts.type == BT_CHARACTER)
3572     return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
3573
3574   return true;
3575 }
3576
3577
3578 bool
3579 gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
3580 {
3581   if (!type_check (i, 0, BT_INTEGER))
3582     return false;
3583
3584   if (!type_check (j, 1, BT_INTEGER))
3585     return false;
3586
3587   if (!type_check (mask, 2, BT_INTEGER))
3588     return false;
3589
3590   if (!same_type_check (i, 0, j, 1))
3591     return false;
3592
3593   if (!same_type_check (i, 0, mask, 2))
3594     return false;
3595
3596   return true;
3597 }
3598
3599
3600 bool
3601 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
3602 {
3603   if (!variable_check (from, 0, false))
3604     return false;
3605   if (!allocatable_check (from, 0))
3606     return false;
3607   if (gfc_is_coindexed (from))
3608     {
3609       gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
3610                  "coindexed", &from->where);
3611       return false;
3612     }
3613
3614   if (!variable_check (to, 1, false))
3615     return false;
3616   if (!allocatable_check (to, 1))
3617     return false;
3618   if (gfc_is_coindexed (to))
3619     {
3620       gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
3621                  "coindexed", &to->where);
3622       return false;
3623     }
3624
3625   if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
3626     {
3627       gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
3628                  "polymorphic if FROM is polymorphic",
3629                  &to->where);
3630       return false;
3631     }
3632
3633   if (!same_type_check (to, 1, from, 0))
3634     return false;
3635
3636   if (to->rank != from->rank)
3637     {
3638       gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3639                  "must have the same rank %d/%d", &to->where,  from->rank,
3640                  to->rank);
3641       return false;
3642     }
3643
3644   /* IR F08/0040; cf. 12-006A.  */
3645   if (gfc_get_corank (to) != gfc_get_corank (from))
3646     {
3647       gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3648                  "must have the same corank %d/%d", &to->where,
3649                  gfc_get_corank (from), gfc_get_corank (to));
3650       return false;
3651     }
3652
3653   /*  This is based losely on F2003 12.4.1.7. It is intended to prevent
3654       the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
3655       and cmp2 are allocatable.  After the allocation is transferred,
3656       the 'to' chain is broken by the nullification of the 'from'. A bit
3657       of reflection reveals that this can only occur for derived types
3658       with recursive allocatable components.  */
3659   if (to->expr_type == EXPR_VARIABLE && from->expr_type == EXPR_VARIABLE
3660       && !strcmp (to->symtree->n.sym->name, from->symtree->n.sym->name))
3661     {
3662       gfc_ref *to_ref, *from_ref;
3663       to_ref = to->ref;
3664       from_ref = from->ref;
3665       bool aliasing = true;
3666
3667       for (; from_ref && to_ref;
3668            from_ref = from_ref->next, to_ref = to_ref->next)
3669         {
3670           if (to_ref->type != from->ref->type)
3671             aliasing = false;
3672           else if (to_ref->type == REF_ARRAY
3673                    && to_ref->u.ar.type != AR_FULL
3674                    && from_ref->u.ar.type != AR_FULL)
3675             /* Play safe; assume sections and elements are different.  */
3676             aliasing = false;
3677           else if (to_ref->type == REF_COMPONENT
3678                    && to_ref->u.c.component != from_ref->u.c.component)
3679             aliasing = false;
3680
3681           if (!aliasing)
3682             break;
3683         }
3684
3685       if (aliasing)
3686         {
3687           gfc_error ("The FROM and TO arguments at %L violate aliasing "
3688                      "restrictions (F2003 12.4.1.7)", &to->where);
3689           return false;
3690         }
3691     }
3692
3693   /* CLASS arguments: Make sure the vtab of from is present.  */
3694   if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from))
3695     gfc_find_vtab (&from->ts);
3696
3697   return true;
3698 }
3699
3700
3701 bool
3702 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
3703 {
3704   if (!type_check (x, 0, BT_REAL))
3705     return false;
3706
3707   if (!type_check (s, 1, BT_REAL))
3708     return false;
3709
3710   if (s->expr_type == EXPR_CONSTANT)
3711     {
3712       if (mpfr_sgn (s->value.real) == 0)
3713         {
3714           gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
3715                      &s->where);
3716           return false;
3717         }
3718     }
3719
3720   return true;
3721 }
3722
3723
3724 bool
3725 gfc_check_new_line (gfc_expr *a)
3726 {
3727   if (!type_check (a, 0, BT_CHARACTER))
3728     return false;
3729
3730   return true;
3731 }
3732
3733
3734 bool
3735 gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
3736 {
3737   if (!type_check (array, 0, BT_REAL))
3738     return false;
3739
3740   if (!array_check (array, 0))
3741     return false;
3742
3743   if (!dim_rank_check (dim, array, false))
3744     return false;
3745
3746   return true;
3747 }
3748
3749 bool
3750 gfc_check_null (gfc_expr *mold)
3751 {
3752   symbol_attribute attr;
3753
3754   if (mold == NULL)
3755     return true;
3756
3757   if (!variable_check (mold, 0, true))
3758     return false;
3759
3760   attr = gfc_variable_attr (mold, NULL);
3761
3762   if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
3763     {
3764       gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
3765                  "ALLOCATABLE or procedure pointer",
3766                  gfc_current_intrinsic_arg[0]->name,
3767                  gfc_current_intrinsic, &mold->where);
3768       return false;
3769     }
3770
3771   if (attr.allocatable
3772       && !gfc_notify_std (GFC_STD_F2003, "NULL intrinsic with "
3773                           "allocatable MOLD at %L", &mold->where))
3774     return false;
3775
3776   /* F2008, C1242.  */
3777   if (gfc_is_coindexed (mold))
3778     {
3779       gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
3780                  "coindexed", gfc_current_intrinsic_arg[0]->name,
3781                  gfc_current_intrinsic, &mold->where);
3782       return false;
3783     }
3784
3785   return true;
3786 }
3787
3788
3789 bool
3790 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
3791 {
3792   if (!array_check (array, 0))
3793     return false;
3794
3795   if (!type_check (mask, 1, BT_LOGICAL))
3796     return false;
3797
3798   if (!gfc_check_conformance (array, mask,
3799                               "arguments '%s' and '%s' for intrinsic '%s'",
3800                               gfc_current_intrinsic_arg[0]->name,
3801                               gfc_current_intrinsic_arg[1]->name,
3802                               gfc_current_intrinsic))
3803     return false;
3804
3805   if (vector != NULL)
3806     {
3807       mpz_t array_size, vector_size;
3808       bool have_array_size, have_vector_size;
3809
3810       if (!same_type_check (array, 0, vector, 2))
3811         return false;
3812
3813       if (!rank_check (vector, 2, 1))
3814         return false;
3815
3816       /* VECTOR requires at least as many elements as MASK
3817          has .TRUE. values.  */
3818       have_array_size = gfc_array_size(array, &array_size);
3819       have_vector_size = gfc_array_size(vector, &vector_size);
3820
3821       if (have_vector_size
3822           && (mask->expr_type == EXPR_ARRAY
3823               || (mask->expr_type == EXPR_CONSTANT
3824                   && have_array_size)))
3825         {
3826           int mask_true_values = 0;
3827
3828           if (mask->expr_type == EXPR_ARRAY)
3829             {
3830               gfc_constructor *mask_ctor;
3831               mask_ctor = gfc_constructor_first (mask->value.constructor);
3832               while (mask_ctor)
3833                 {
3834                   if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
3835                     {
3836                       mask_true_values = 0;
3837                       break;
3838                     }
3839
3840                   if (mask_ctor->expr->value.logical)
3841                     mask_true_values++;
3842
3843                   mask_ctor = gfc_constructor_next (mask_ctor);
3844                 }
3845             }
3846           else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
3847             mask_true_values = mpz_get_si (array_size);
3848
3849           if (mpz_get_si (vector_size) < mask_true_values)
3850             {
3851               gfc_error ("%qs argument of %qs intrinsic at %L must "
3852                          "provide at least as many elements as there "
3853                          "are .TRUE. values in %qs (%ld/%d)",
3854                          gfc_current_intrinsic_arg[2]->name,
3855                          gfc_current_intrinsic, &vector->where,
3856                          gfc_current_intrinsic_arg[1]->name,
3857                          mpz_get_si (vector_size), mask_true_values);
3858               return false;
3859             }
3860         }
3861
3862       if (have_array_size)
3863         mpz_clear (array_size);
3864       if (have_vector_size)
3865         mpz_clear (vector_size);
3866     }
3867
3868   return true;
3869 }
3870
3871
3872 bool
3873 gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
3874 {
3875   if (!type_check (mask, 0, BT_LOGICAL))
3876     return false;
3877
3878   if (!array_check (mask, 0))
3879     return false;
3880
3881   if (!dim_rank_check (dim, mask, false))
3882     return false;
3883
3884   return true;
3885 }
3886
3887
3888 bool
3889 gfc_check_precision (gfc_expr *x)
3890 {
3891   if (!real_or_complex_check (x, 0))
3892     return false;
3893
3894   return true;
3895 }
3896
3897
3898 bool
3899 gfc_check_present (gfc_expr *a)
3900 {
3901   gfc_symbol *sym;
3902
3903   if (!variable_check (a, 0, true))
3904     return false;
3905
3906   sym = a->symtree->n.sym;
3907   if (!sym->attr.dummy)
3908     {
3909       gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
3910                  "dummy variable", gfc_current_intrinsic_arg[0]->name,
3911                  gfc_current_intrinsic, &a->where);
3912       return false;
3913     }
3914
3915   if (!sym->attr.optional)
3916     {
3917       gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3918                  "an OPTIONAL dummy variable",
3919                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3920                  &a->where);
3921       return false;
3922     }
3923
3924   /* 13.14.82  PRESENT(A)
3925      ......
3926      Argument.  A shall be the name of an optional dummy argument that is
3927      accessible in the subprogram in which the PRESENT function reference
3928      appears...  */
3929
3930   if (a->ref != NULL
3931       && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
3932            && (a->ref->u.ar.type == AR_FULL
3933                || (a->ref->u.ar.type == AR_ELEMENT
3934                    && a->ref->u.ar.as->rank == 0))))
3935     {
3936       gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
3937                  "subobject of %qs", gfc_current_intrinsic_arg[0]->name,
3938                  gfc_current_intrinsic, &a->where, sym->name);
3939       return false;
3940     }
3941
3942   return true;
3943 }
3944
3945
3946 bool
3947 gfc_check_radix (gfc_expr *x)
3948 {
3949   if (!int_or_real_check (x, 0))
3950     return false;
3951
3952   return true;
3953 }
3954
3955
3956 bool
3957 gfc_check_range (gfc_expr *x)
3958 {
3959   if (!numeric_check (x, 0))
3960     return false;
3961
3962   return true;
3963 }
3964
3965
3966 bool
3967 gfc_check_rank (gfc_expr *a)
3968 {
3969   /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3970      variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45).  */
3971
3972   bool is_variable = true;
3973
3974   /* Functions returning pointers are regarded as variable, cf. F2008, R602.  */
3975   if (a->expr_type == EXPR_FUNCTION)
3976     is_variable = a->value.function.esym
3977                   ? a->value.function.esym->result->attr.pointer
3978                   : a->symtree->n.sym->result->attr.pointer;
3979
3980   if (a->expr_type == EXPR_OP
3981       || a->expr_type == EXPR_NULL
3982       || a->expr_type == EXPR_COMPCALL
3983       || a->expr_type == EXPR_PPC
3984       || a->ts.type == BT_PROCEDURE
3985       || !is_variable)
3986     {
3987       gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3988                  "object", &a->where);
3989       return false;
3990     }
3991
3992   return true;
3993 }
3994
3995
3996 /* real, float, sngl.  */
3997 bool
3998 gfc_check_real (gfc_expr *a, gfc_expr *kind)
3999 {
4000   if (!numeric_check (a, 0))
4001     return false;
4002
4003   if (!kind_check (kind, 1, BT_REAL))
4004     return false;
4005
4006   return true;
4007 }
4008
4009
4010 bool
4011 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
4012 {
4013   if (!type_check (path1, 0, BT_CHARACTER))
4014     return false;
4015   if (!kind_value_check (path1, 0, gfc_default_character_kind))
4016     return false;
4017
4018   if (!type_check (path2, 1, BT_CHARACTER))
4019     return false;
4020   if (!kind_value_check (path2, 1, gfc_default_character_kind))
4021     return false;
4022
4023   return true;
4024 }
4025
4026
4027 bool
4028 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
4029 {
4030   if (!type_check (path1, 0, BT_CHARACTER))
4031     return false;
4032   if (!kind_value_check (path1, 0, gfc_default_character_kind))
4033     return false;
4034
4035   if (!type_check (path2, 1, BT_CHARACTER))
4036     return false;
4037   if (!kind_value_check (path2, 1, gfc_default_character_kind))
4038     return false;
4039
4040   if (status == NULL)
4041     return true;
4042
4043   if (!type_check (status, 2, BT_INTEGER))
4044     return false;
4045
4046   if (!scalar_check (status, 2))
4047     return false;
4048
4049   return true;
4050 }
4051
4052
4053 bool
4054 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
4055 {
4056   if (!type_check (x, 0, BT_CHARACTER))
4057     return false;
4058
4059   if (!scalar_check (x, 0))
4060     return false;
4061
4062   if (!type_check (y, 0, BT_INTEGER))
4063     return false;
4064
4065   if (!scalar_check (y, 1))
4066     return false;
4067
4068   return true;
4069 }
4070
4071
4072 bool
4073 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
4074                    gfc_expr *pad, gfc_expr *order)
4075 {
4076   mpz_t size;
4077   mpz_t nelems;
4078   int shape_size;
4079
4080   if (!array_check (source, 0))
4081     return false;
4082
4083   if (!rank_check (shape, 1, 1))
4084     return false;
4085
4086   if (!type_check (shape, 1, BT_INTEGER))
4087     return false;
4088
4089   if (!gfc_array_size (shape, &size))
4090     {
4091       gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
4092                  "array of constant size", &shape->where);
4093       return false;
4094     }
4095
4096   shape_size = mpz_get_ui (size);
4097   mpz_clear (size);
4098
4099   if (shape_size <= 0)
4100     {
4101       gfc_error ("%qs argument of %qs intrinsic at %L is empty",
4102                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4103                  &shape->where);
4104       return false;
4105     }
4106   else if (shape_size > GFC_MAX_DIMENSIONS)
4107     {
4108       gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
4109                  "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
4110       return false;
4111     }
4112   else if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape))
4113     {
4114       gfc_expr *e;
4115       int i, extent;
4116       for (i = 0; i < shape_size; ++i)
4117         {
4118           e = gfc_constructor_lookup_expr (shape->value.constructor, i);
4119           if (e->expr_type != EXPR_CONSTANT)
4120             continue;
4121
4122           gfc_extract_int (e, &extent);
4123           if (extent < 0)
4124             {
4125               gfc_error ("%qs argument of %qs intrinsic at %L has "
4126                          "negative element (%d)",
4127                          gfc_current_intrinsic_arg[1]->name,
4128                          gfc_current_intrinsic, &e->where, extent);
4129               return false;
4130             }
4131         }
4132     }
4133   else if (shape->expr_type == EXPR_VARIABLE && shape->ref
4134            && shape->ref->u.ar.type == AR_FULL && shape->ref->u.ar.dimen == 1
4135            && shape->ref->u.ar.as
4136            && shape->ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
4137            && shape->ref->u.ar.as->lower[0]->ts.type == BT_INTEGER
4138            && shape->ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT
4139            && shape->ref->u.ar.as->upper[0]->ts.type == BT_INTEGER
4140            && shape->symtree->n.sym->attr.flavor == FL_PARAMETER)
4141     {
4142       int i, extent;
4143       gfc_expr *e, *v;
4144
4145       v = shape->symtree->n.sym->value;
4146
4147       for (i = 0; i < shape_size; i++)
4148         {
4149           e = gfc_constructor_lookup_expr (v->value.constructor, i);
4150           if (e == NULL)
4151              break;
4152
4153           gfc_extract_int (e, &extent);
4154
4155           if (extent < 0)
4156             {
4157               gfc_error ("Element %d of actual argument of RESHAPE at %L "
4158                          "cannot be negative", i + 1, &shape->where);
4159               return false;
4160             }
4161         }
4162     }
4163
4164   if (pad != NULL)
4165     {
4166       if (!same_type_check (source, 0, pad, 2))
4167         return false;
4168
4169       if (!array_check (pad, 2))
4170         return false;
4171     }
4172
4173   if (order != NULL)
4174     {
4175       if (!array_check (order, 3))
4176         return false;
4177
4178       if (!type_check (order, 3, BT_INTEGER))
4179         return false;
4180
4181       if (order->expr_type == EXPR_ARRAY && gfc_is_constant_expr (order))
4182         {
4183           int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
4184           gfc_expr *e;
4185
4186           for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
4187             perm[i] = 0;
4188
4189           gfc_array_size (order, &size);
4190           order_size = mpz_get_ui (size);
4191           mpz_clear (size);
4192
4193           if (order_size != shape_size)
4194             {
4195               gfc_error ("%qs argument of %qs intrinsic at %L "
4196                          "has wrong number of elements (%d/%d)",
4197                          gfc_current_intrinsic_arg[3]->name,
4198                          gfc_current_intrinsic, &order->where,
4199                          order_size, shape_size);
4200               return false;
4201             }
4202
4203           for (i = 1; i <= order_size; ++i)
4204             {
4205               e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
4206               if (e->expr_type != EXPR_CONSTANT)
4207                 continue;
4208
4209               gfc_extract_int (e, &dim);
4210
4211               if (dim < 1 || dim > order_size)
4212                 {
4213                   gfc_error ("%qs argument of %qs intrinsic at %L "
4214                              "has out-of-range dimension (%d)",
4215                              gfc_current_intrinsic_arg[3]->name,
4216                              gfc_current_intrinsic, &e->where, dim);
4217                   return false;
4218                 }
4219
4220               if (perm[dim-1] != 0)
4221                 {
4222                   gfc_error ("%qs argument of %qs intrinsic at %L has "
4223                              "invalid permutation of dimensions (dimension "
4224                              "%qd duplicated)",
4225                              gfc_current_intrinsic_arg[3]->name,
4226                              gfc_current_intrinsic, &e->where, dim);
4227                   return false;
4228                 }
4229
4230               perm[dim-1] = 1;
4231             }
4232         }
4233     }
4234
4235   if (pad == NULL && shape->expr_type == EXPR_ARRAY
4236       && gfc_is_constant_expr (shape)
4237       && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
4238            && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
4239     {
4240       /* Check the match in size between source and destination.  */
4241       if (gfc_array_size (source, &nelems))
4242         {
4243           gfc_constructor *c;
4244           bool test;
4245
4246
4247           mpz_init_set_ui (size, 1);
4248           for (c = gfc_constructor_first (shape->value.constructor);
4249                c; c = gfc_constructor_next (c))
4250             mpz_mul (size, size, c->expr->value.integer);
4251
4252           test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
4253           mpz_clear (nelems);
4254           mpz_clear (size);
4255
4256           if (test)
4257             {
4258               gfc_error ("Without padding, there are not enough elements "
4259                          "in the intrinsic RESHAPE source at %L to match "
4260                          "the shape", &source->where);
4261               return false;
4262             }
4263         }
4264     }
4265
4266   return true;
4267 }
4268
4269
4270 bool
4271 gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
4272 {
4273   if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
4274     {
4275         gfc_error ("%qs argument of %qs intrinsic at %L "
4276                    "cannot be of type %s",
4277                    gfc_current_intrinsic_arg[0]->name,
4278                    gfc_current_intrinsic,
4279                    &a->where, gfc_typename (&a->ts));
4280         return false;
4281     }
4282
4283   if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a)))
4284     {
4285       gfc_error ("%qs argument of %qs intrinsic at %L "
4286                  "must be of an extensible type",
4287                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4288                  &a->where);
4289       return false;
4290     }
4291
4292   if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
4293     {
4294         gfc_error ("%qs argument of %qs intrinsic at %L "
4295                    "cannot be of type %s",
4296                    gfc_current_intrinsic_arg[0]->name,
4297                    gfc_current_intrinsic,
4298                    &b->where, gfc_typename (&b->ts));
4299       return false;
4300     }
4301
4302   if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b)))
4303     {
4304       gfc_error ("%qs argument of %qs intrinsic at %L "
4305                  "must be of an extensible type",
4306                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4307                  &b->where);
4308       return false;
4309     }
4310
4311   return true;
4312 }
4313
4314
4315 bool
4316 gfc_check_scale (gfc_expr *x, gfc_expr *i)
4317 {
4318   if (!type_check (x, 0, BT_REAL))
4319     return false;
4320
4321   if (!type_check (i, 1, BT_INTEGER))
4322     return false;
4323
4324   return true;
4325 }
4326
4327
4328 bool
4329 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
4330 {
4331   if (!type_check (x, 0, BT_CHARACTER))
4332     return false;
4333
4334   if (!type_check (y, 1, BT_CHARACTER))
4335     return false;
4336
4337   if (z != NULL && !type_check (z, 2, BT_LOGICAL))
4338     return false;
4339
4340   if (!kind_check (kind, 3, BT_INTEGER))
4341     return false;
4342   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
4343                                "with KIND argument at %L",
4344                                gfc_current_intrinsic, &kind->where))
4345     return false;
4346
4347   if (!same_type_check (x, 0, y, 1))
4348     return false;
4349
4350   return true;
4351 }
4352
4353
4354 bool
4355 gfc_check_secnds (gfc_expr *r)
4356 {
4357   if (!type_check (r, 0, BT_REAL))
4358     return false;
4359
4360   if (!kind_value_check (r, 0, 4))
4361     return false;
4362
4363   if (!scalar_check (r, 0))
4364     return false;
4365
4366   return true;
4367 }
4368
4369
4370 bool
4371 gfc_check_selected_char_kind (gfc_expr *name)
4372 {
4373   if (!type_check (name, 0, BT_CHARACTER))
4374     return false;
4375
4376   if (!kind_value_check (name, 0, gfc_default_character_kind))
4377     return false;
4378
4379   if (!scalar_check (name, 0))
4380     return false;
4381
4382   return true;
4383 }
4384
4385
4386 bool
4387 gfc_check_selected_int_kind (gfc_expr *r)
4388 {
4389   if (!type_check (r, 0, BT_INTEGER))
4390     return false;
4391
4392   if (!scalar_check (r, 0))
4393     return false;
4394
4395   return true;
4396 }
4397
4398
4399 bool
4400 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
4401 {
4402   if (p == NULL && r == NULL
4403       && !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with"
4404                           " neither %<P%> nor %<R%> argument at %L",
4405                           gfc_current_intrinsic_where))
4406     return false;
4407
4408   if (p)
4409     {
4410       if (!type_check (p, 0, BT_INTEGER))
4411         return false;
4412
4413       if (!scalar_check (p, 0))
4414         return false;
4415     }
4416
4417   if (r)
4418     {
4419       if (!type_check (r, 1, BT_INTEGER))
4420         return false;
4421
4422       if (!scalar_check (r, 1))
4423         return false;
4424     }
4425
4426   if (radix)
4427     {
4428       if (!type_check (radix, 1, BT_INTEGER))
4429         return false;
4430
4431       if (!scalar_check (radix, 1))
4432         return false;
4433
4434       if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with "
4435                            "RADIX argument at %L", gfc_current_intrinsic,
4436                            &radix->where))
4437         return false;
4438     }
4439
4440   return true;
4441 }
4442
4443
4444 bool
4445 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
4446 {
4447   if (!type_check (x, 0, BT_REAL))
4448     return false;
4449
4450   if (!type_check (i, 1, BT_INTEGER))
4451     return false;
4452
4453   return true;
4454 }
4455
4456
4457 bool
4458 gfc_check_shape (gfc_expr *source, gfc_expr *kind)
4459 {
4460   gfc_array_ref *ar;
4461
4462   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
4463     return true;
4464
4465   ar = gfc_find_array_ref (source);
4466
4467   if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
4468     {
4469       gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
4470                  "an assumed size array", &source->where);
4471       return false;
4472     }
4473
4474   if (!kind_check (kind, 1, BT_INTEGER))
4475     return false;
4476   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
4477                                "with KIND argument at %L",
4478                                gfc_current_intrinsic, &kind->where))
4479     return false;
4480
4481   return true;
4482 }
4483
4484
4485 bool
4486 gfc_check_shift (gfc_expr *i, gfc_expr *shift)
4487 {
4488   if (!type_check (i, 0, BT_INTEGER))
4489     return false;
4490
4491   if (!type_check (shift, 0, BT_INTEGER))
4492     return false;
4493
4494   if (!nonnegative_check ("SHIFT", shift))
4495     return false;
4496
4497   if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
4498     return false;
4499
4500   return true;
4501 }
4502
4503
4504 bool
4505 gfc_check_sign (gfc_expr *a, gfc_expr *b)
4506 {
4507   if (!int_or_real_check (a, 0))
4508     return false;
4509
4510   if (!same_type_check (a, 0, b, 1))
4511     return false;
4512
4513   return true;
4514 }
4515
4516
4517 bool
4518 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4519 {
4520   if (!array_check (array, 0))
4521     return false;
4522
4523   if (!dim_check (dim, 1, true))
4524     return false;
4525
4526   if (!dim_rank_check (dim, array, 0))
4527     return false;
4528
4529   if (!kind_check (kind, 2, BT_INTEGER))
4530     return false;
4531   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
4532                                "with KIND argument at %L",
4533                                gfc_current_intrinsic, &kind->where))
4534     return false;
4535
4536
4537   return true;
4538 }
4539
4540
4541 bool
4542 gfc_check_sizeof (gfc_expr *arg)
4543 {
4544   if (arg->ts.type == BT_PROCEDURE)
4545     {
4546       gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
4547                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4548                  &arg->where);
4549       return false;
4550     }
4551
4552   /* TYPE(*) is acceptable if and only if it uses an array descriptor.  */
4553   if (arg->ts.type == BT_ASSUMED
4554       && (arg->symtree->n.sym->as == NULL
4555           || (arg->symtree->n.sym->as->type != AS_ASSUMED_SHAPE
4556               && arg->symtree->n.sym->as->type != AS_DEFERRED
4557               && arg->symtree->n.sym->as->type != AS_ASSUMED_RANK)))
4558     {
4559       gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
4560                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4561                  &arg->where);
4562       return false;
4563     }
4564
4565   if (arg->rank && arg->expr_type == EXPR_VARIABLE
4566       && arg->symtree->n.sym->as != NULL
4567       && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
4568       && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
4569     {
4570       gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4571                  "assumed-size array", gfc_current_intrinsic_arg[0]->name,
4572                  gfc_current_intrinsic, &arg->where);
4573       return false;
4574     }
4575
4576   return true;
4577 }
4578
4579
4580 /* Check whether an expression is interoperable.  When returning false,
4581    msg is set to a string telling why the expression is not interoperable,
4582    otherwise, it is set to NULL.  The msg string can be used in diagnostics.
4583    If c_loc is true, character with len > 1 are allowed (cf. Fortran
4584    2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
4585    arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
4586    are permitted.  */
4587
4588 static bool
4589 is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr)
4590 {
4591   *msg = NULL;
4592
4593   if (expr->ts.type == BT_CLASS)
4594     {
4595       *msg = "Expression is polymorphic";
4596       return false;
4597     }
4598
4599   if (expr->ts.type == BT_DERIVED && !expr->ts.u.derived->attr.is_bind_c
4600       && !expr->ts.u.derived->ts.is_iso_c)
4601     {
4602       *msg = "Expression is a noninteroperable derived type";
4603       return false;
4604     }
4605
4606   if (expr->ts.type == BT_PROCEDURE)
4607     {
4608       *msg = "Procedure unexpected as argument";
4609       return false;
4610     }
4611
4612   if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_LOGICAL)
4613     {
4614       int i;
4615       for (i = 0; gfc_logical_kinds[i].kind; i++)
4616         if (gfc_logical_kinds[i].kind == expr->ts.kind)
4617           return true;
4618       *msg = "Extension to use a non-C_Bool-kind LOGICAL";
4619       return false;
4620     }
4621
4622   if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_CHARACTER
4623       && expr->ts.kind != 1)
4624     {
4625       *msg = "Extension to use a non-C_CHAR-kind CHARACTER";
4626       return false;
4627     }
4628
4629   if (expr->ts.type == BT_CHARACTER) {
4630     if (expr->ts.deferred)
4631       {
4632         /* TS 29113 allows deferred-length strings as dummy arguments,
4633            but it is not an interoperable type.  */
4634         *msg = "Expression shall not be a deferred-length string";
4635         return false;
4636       }
4637
4638     if (expr->ts.u.cl && expr->ts.u.cl->length
4639         && !gfc_simplify_expr (expr->ts.u.cl->length, 0))
4640       gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
4641
4642     if (!c_loc && expr->ts.u.cl
4643         && (!expr->ts.u.cl->length
4644             || expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
4645             || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0))
4646       {
4647         *msg = "Type shall have a character length of 1";
4648         return false;
4649       }
4650     }
4651
4652   /* Note: The following checks are about interoperatable variables, Fortran
4653      15.3.5/15.3.6.  In intrinsics like C_LOC or in procedure interface, more
4654      is allowed, e.g. assumed-shape arrays with TS 29113.  */
4655
4656   if (gfc_is_coarray (expr))
4657     {
4658       *msg = "Coarrays are not interoperable";
4659       return false;
4660     }
4661
4662   if (!c_loc && expr->rank > 0 && expr->expr_type != EXPR_ARRAY)
4663     {
4664       gfc_array_ref *ar = gfc_find_array_ref (expr);
4665       if (ar->type != AR_FULL)
4666         {
4667           *msg = "Only whole-arrays are interoperable";
4668           return false;
4669         }
4670       if (!c_f_ptr && ar->as->type != AS_EXPLICIT
4671           && ar->as->type != AS_ASSUMED_SIZE)
4672         {
4673           *msg = "Only explicit-size and assumed-size arrays are interoperable";
4674           return false;
4675         }
4676     }
4677
4678   return true;
4679 }
4680
4681
4682 bool
4683 gfc_check_c_sizeof (gfc_expr *arg)
4684 {
4685   const char *msg;
4686
4687   if (!is_c_interoperable (arg, &msg, false, false))
4688     {
4689       gfc_error ("%qs argument of %qs intrinsic at %L must be an "
4690                  "interoperable data entity: %s",
4691                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4692                  &arg->where, msg);
4693       return false;
4694     }
4695
4696   if (arg->ts.type == BT_ASSUMED)
4697     {
4698       gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4699                  "TYPE(*)",
4700                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4701                  &arg->where);
4702       return false;
4703     }
4704
4705   if (arg->rank && arg->expr_type == EXPR_VARIABLE
4706       && arg->symtree->n.sym->as != NULL
4707       && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
4708       && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
4709     {
4710       gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4711                  "assumed-size array", gfc_current_intrinsic_arg[0]->name,
4712                  gfc_current_intrinsic, &arg->where);
4713       return false;
4714     }
4715
4716   return true;
4717 }
4718
4719
4720 bool
4721 gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
4722 {
4723   if (c_ptr_1->ts.type != BT_DERIVED
4724       || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
4725       || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
4726           && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
4727     {
4728       gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
4729                  "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
4730       return false;
4731     }
4732
4733   if (!scalar_check (c_ptr_1, 0))
4734     return false;
4735
4736   if (c_ptr_2
4737       && (c_ptr_2->ts.type != BT_DERIVED
4738           || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
4739           || (c_ptr_1->ts.u.derived->intmod_sym_id
4740               != c_ptr_2->ts.u.derived->intmod_sym_id)))
4741     {
4742       gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
4743                  "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where,
4744                  gfc_typename (&c_ptr_1->ts),
4745                  gfc_typename (&c_ptr_2->ts));
4746       return false;
4747     }
4748
4749   if (c_ptr_2 && !scalar_check (c_ptr_2, 1))
4750     return false;
4751
4752   return true;
4753 }
4754
4755
4756 bool
4757 gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
4758 {
4759   symbol_attribute attr;
4760   const char *msg;
4761
4762   if (cptr->ts.type != BT_DERIVED
4763       || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
4764       || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
4765     {
4766       gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
4767                  "type TYPE(C_PTR)", &cptr->where);
4768       return false;
4769     }
4770
4771   if (!scalar_check (cptr, 0))
4772     return false;
4773
4774   attr = gfc_expr_attr (fptr);
4775
4776   if (!attr.pointer)
4777     {
4778       gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
4779                  &fptr->where);
4780       return false;
4781     }
4782
4783   if (fptr->ts.type == BT_CLASS)
4784     {
4785       gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
4786                  &fptr->where);
4787       return false;
4788     }
4789
4790   if (gfc_is_coindexed (fptr))
4791     {
4792       gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
4793                  "coindexed", &fptr->where);
4794       return false;
4795     }
4796
4797   if (fptr->rank == 0 && shape)
4798     {
4799       gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
4800                  "FPTR", &fptr->where);
4801       return false;
4802     }
4803   else if (fptr->rank && !shape)
4804     {
4805       gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
4806                  "FPTR at %L", &fptr->where);
4807       return false;
4808     }
4809
4810   if (shape && !rank_check (shape, 2, 1))
4811     return false;
4812
4813   if (shape && !type_check (shape, 2, BT_INTEGER))
4814     return false;
4815
4816   if (shape)
4817     {
4818       mpz_t size;
4819       if (gfc_array_size (shape, &size))
4820         {
4821           if (mpz_cmp_ui (size, fptr->rank) != 0)
4822             {
4823               mpz_clear (size);
4824               gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
4825                         "size as the RANK of FPTR", &shape->where);
4826               return false;
4827             }
4828           mpz_clear (size);
4829         }
4830     }
4831
4832   if (fptr->ts.type == BT_CLASS)
4833     {
4834       gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where);
4835       return false;
4836     }
4837
4838   if (fptr->rank > 0 && !is_c_interoperable (fptr, &msg, false, true))
4839     return gfc_notify_std (GFC_STD_F2018, "Noninteroperable array FPTR "
4840                            "at %L to C_F_POINTER: %s", &fptr->where, msg);
4841
4842   return true;
4843 }
4844
4845
4846 bool
4847 gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr)
4848 {
4849   symbol_attribute attr;
4850
4851   if (cptr->ts.type != BT_DERIVED
4852       || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
4853       || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)
4854     {
4855       gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
4856                  "type TYPE(C_FUNPTR)", &cptr->where);
4857       return false;
4858     }
4859
4860   if (!scalar_check (cptr, 0))
4861     return false;
4862
4863   attr = gfc_expr_attr (fptr);
4864
4865   if (!attr.proc_pointer)
4866     {
4867       gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4868                  "pointer", &fptr->where);
4869       return false;
4870     }
4871
4872   if (gfc_is_coindexed (fptr))
4873     {
4874       gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4875                  "coindexed", &fptr->where);
4876       return false;
4877     }
4878
4879   if (!attr.is_bind_c)
4880     return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure "
4881                            "pointer at %L to C_F_PROCPOINTER", &fptr->where);
4882
4883   return true;
4884 }
4885
4886
4887 bool
4888 gfc_check_c_funloc (gfc_expr *x)
4889 {
4890   symbol_attribute attr;
4891
4892   if (gfc_is_coindexed (x))
4893     {
4894       gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4895                  "coindexed", &x->where);
4896       return false;
4897     }
4898
4899   attr = gfc_expr_attr (x);
4900
4901   if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE
4902       && x->symtree->n.sym == x->symtree->n.sym->result)
4903     {
4904       gfc_namespace *ns = gfc_current_ns;
4905
4906       for (ns = gfc_current_ns; ns; ns = ns->parent)
4907         if (x->symtree->n.sym == ns->proc_name)
4908           {
4909             gfc_error ("Function result %qs at %L is invalid as X argument "
4910                        "to C_FUNLOC", x->symtree->n.sym->name, &x->where);
4911             return false;
4912           }
4913     }
4914
4915   if (attr.flavor != FL_PROCEDURE)
4916     {
4917       gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4918                  "or a procedure pointer", &x->where);
4919       return false;
4920     }
4921
4922   if (!attr.is_bind_c)
4923     return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure "
4924                            "at %L to C_FUNLOC", &x->where);
4925   return true;
4926 }
4927
4928
4929 bool
4930 gfc_check_c_loc (gfc_expr *x)
4931 {
4932   symbol_attribute attr;
4933   const char *msg;
4934
4935   if (gfc_is_coindexed (x))
4936     {
4937       gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where);
4938       return false;
4939     }
4940
4941   if (x->ts.type == BT_CLASS)
4942     {
4943       gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4944                  &x->where);
4945       return false;
4946     }
4947
4948   attr = gfc_expr_attr (x);
4949
4950   if (!attr.pointer
4951       && (x->expr_type != EXPR_VARIABLE || !attr.target
4952           || attr.flavor == FL_PARAMETER))
4953     {
4954       gfc_error ("Argument X at %L to C_LOC shall have either "
4955                  "the POINTER or the TARGET attribute", &x->where);
4956       return false;
4957     }
4958
4959   if (x->ts.type == BT_CHARACTER
4960       && gfc_var_strlen (x) == 0)
4961     {
4962       gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4963                  "string", &x->where);
4964       return false;
4965     }
4966
4967   if (!is_c_interoperable (x, &msg, true, false))
4968     {
4969       if (x->ts.type == BT_CLASS)
4970         {
4971           gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4972                      &x->where);
4973           return false;
4974         }
4975
4976       if (x->rank
4977           && !gfc_notify_std (GFC_STD_F2018,
4978                               "Noninteroperable array at %L as"
4979                               " argument to C_LOC: %s", &x->where, msg))
4980           return false;
4981     }
4982   else if (x->rank > 0 && gfc_notification_std (GFC_STD_F2008))
4983     {
4984       gfc_array_ref *ar = gfc_find_array_ref (x);
4985
4986       if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE
4987           && !attr.allocatable
4988           && !gfc_notify_std (GFC_STD_F2008,
4989                               "Array of interoperable type at %L "
4990                               "to C_LOC which is nonallocatable and neither "
4991                               "assumed size nor explicit size", &x->where))
4992         return false;
4993       else if (ar->type != AR_FULL
4994                && !gfc_notify_std (GFC_STD_F2008, "Array section at %L "
4995                                    "to C_LOC", &x->where))
4996         return false;
4997     }
4998
4999   return true;
5000 }
5001
5002
5003 bool
5004 gfc_check_sleep_sub (gfc_expr *seconds)
5005 {
5006   if (!type_check (seconds, 0, BT_INTEGER))
5007     return false;
5008
5009   if (!scalar_check (seconds, 0))
5010     return false;
5011
5012   return true;
5013 }
5014
5015 bool
5016 gfc_check_sngl (gfc_expr *a)
5017 {
5018   if (!type_check (a, 0, BT_REAL))
5019     return false;
5020
5021   if ((a->ts.kind != gfc_default_double_kind)
5022       && !gfc_notify_std (GFC_STD_GNU, "non double precision "
5023                           "REAL argument to %s intrinsic at %L",
5024                           gfc_current_intrinsic, &a->where))
5025     return false;
5026
5027   return true;
5028 }
5029
5030 bool
5031 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
5032 {
5033   if (source->rank >= GFC_MAX_DIMENSIONS)
5034     {
5035       gfc_error ("%qs argument of %qs intrinsic at %L must be less "
5036                  "than rank %d", gfc_current_intrinsic_arg[0]->name,
5037                  gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
5038
5039       return false;
5040     }
5041
5042   if (dim == NULL)
5043     return false;
5044
5045   if (!dim_check (dim, 1, false))
5046     return false;
5047
5048   /* dim_rank_check() does not apply here.  */
5049   if (dim
5050       && dim->expr_type == EXPR_CONSTANT
5051       && (mpz_cmp_ui (dim->value.integer, 1) < 0
5052           || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
5053     {
5054       gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
5055                  "dimension index", gfc_current_intrinsic_arg[1]->name,
5056                  gfc_current_intrinsic, &dim->where);
5057       return false;
5058     }
5059
5060   if (!type_check (ncopies, 2, BT_INTEGER))
5061     return false;
5062
5063   if (!scalar_check (ncopies, 2))
5064     return false;
5065
5066   return true;
5067 }
5068
5069
5070 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
5071    functions).  */
5072
5073 bool
5074 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
5075 {
5076   if (!type_check (unit, 0, BT_INTEGER))
5077     return false;
5078
5079   if (!scalar_check (unit, 0))
5080     return false;
5081
5082   if (!type_check (c, 1, BT_CHARACTER))
5083     return false;
5084   if (!kind_value_check (c, 1, gfc_default_character_kind))
5085     return false;
5086
5087   if (status == NULL)
5088     return true;
5089
5090   if (!type_check (status, 2, BT_INTEGER)
5091       || !kind_value_check (status, 2, gfc_default_integer_kind)
5092       || !scalar_check (status, 2))
5093     return false;
5094
5095   return true;
5096 }
5097
5098
5099 bool
5100 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
5101 {
5102   return gfc_check_fgetputc_sub (unit, c, NULL);
5103 }
5104
5105
5106 bool
5107 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
5108 {
5109   if (!type_check (c, 0, BT_CHARACTER))
5110     return false;
5111   if (!kind_value_check (c, 0, gfc_default_character_kind))
5112     return false;
5113
5114   if (status == NULL)
5115     return true;
5116
5117   if (!type_check (status, 1, BT_INTEGER)
5118       || !kind_value_check (status, 1, gfc_default_integer_kind)
5119       || !scalar_check (status, 1))
5120     return false;
5121
5122   return true;
5123 }
5124
5125
5126 bool
5127 gfc_check_fgetput (gfc_expr *c)
5128 {
5129   return gfc_check_fgetput_sub (c, NULL);
5130 }
5131
5132
5133 bool
5134 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
5135 {
5136   if (!type_check (unit, 0, BT_INTEGER))
5137     return false;
5138
5139   if (!scalar_check (unit, 0))
5140     return false;
5141
5142   if (!type_check (offset, 1, BT_INTEGER))
5143     return false;
5144
5145   if (!scalar_check (offset, 1))
5146     return false;
5147
5148   if (!type_check (whence, 2, BT_INTEGER))
5149     return false;
5150
5151   if (!scalar_check (whence, 2))
5152     return false;
5153
5154   if (status == NULL)
5155     return true;
5156
5157   if (!type_check (status, 3, BT_INTEGER))
5158     return false;
5159
5160   if (!kind_value_check (status, 3, 4))
5161     return false;
5162
5163   if (!scalar_check (status, 3))
5164     return false;
5165
5166   return true;
5167 }
5168
5169
5170
5171 bool
5172 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
5173 {
5174   if (!type_check (unit, 0, BT_INTEGER))
5175     return false;
5176
5177   if (!scalar_check (unit, 0))
5178     return false;
5179
5180   if (!type_check (array, 1, BT_INTEGER)
5181       || !kind_value_check (unit, 0, gfc_default_integer_kind))
5182     return false;
5183
5184   if (!array_check (array, 1))
5185     return false;
5186
5187   return true;
5188 }
5189
5190
5191 bool
5192 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
5193 {
5194   if (!type_check (unit, 0, BT_INTEGER))
5195     return false;
5196
5197   if (!scalar_check (unit, 0))
5198     return false;
5199
5200   if (!type_check (array, 1, BT_INTEGER)
5201       || !kind_value_check (array, 1, gfc_default_integer_kind))
5202     return false;
5203
5204   if (!array_check (array, 1))
5205     return false;
5206
5207   if (status == NULL)
5208     return true;
5209
5210   if (!type_check (status, 2, BT_INTEGER)
5211       || !kind_value_check (status, 2, gfc_default_integer_kind))
5212     return false;
5213
5214   if (!scalar_check (status, 2))
5215     return false;
5216
5217   return true;
5218 }
5219
5220
5221 bool
5222 gfc_check_ftell (gfc_expr *unit)
5223 {
5224   if (!type_check (unit, 0, BT_INTEGER))
5225     return false;
5226
5227   if (!scalar_check (unit, 0))
5228     return false;
5229
5230   return true;
5231 }
5232
5233
5234 bool
5235 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
5236 {
5237   if (!type_check (unit, 0, BT_INTEGER))
5238     return false;
5239
5240   if (!scalar_check (unit, 0))
5241     return false;
5242
5243   if (!type_check (offset, 1, BT_INTEGER))
5244     return false;
5245
5246   if (!scalar_check (offset, 1))
5247     return false;
5248
5249   return true;
5250 }
5251
5252
5253 bool
5254 gfc_check_stat (gfc_expr *name, gfc_expr *array)
5255 {
5256   if (!type_check (name, 0, BT_CHARACTER))
5257     return false;
5258   if (!kind_value_check (name, 0, gfc_default_character_kind))
5259     return false;
5260
5261   if (!type_check (array, 1, BT_INTEGER)
5262       || !kind_value_check (array, 1, gfc_default_integer_kind))
5263     return false;
5264
5265   if (!array_check (array, 1))
5266     return false;
5267
5268   return true;
5269 }
5270
5271
5272 bool
5273 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
5274 {
5275   if (!type_check (name, 0, BT_CHARACTER))
5276     return false;
5277   if (!kind_value_check (name, 0, gfc_default_character_kind))
5278     return false;
5279
5280   if (!type_check (array, 1, BT_INTEGER)
5281       || !kind_value_check (array, 1, gfc_default_integer_kind))
5282     return false;
5283
5284   if (!array_check (array, 1))
5285     return false;
5286
5287   if (status == NULL)
5288     return true;
5289
5290   if (!type_check (status, 2, BT_INTEGER)
5291       || !kind_value_check (array, 1, gfc_default_integer_kind))
5292     return false;
5293
5294   if (!scalar_check (status, 2))
5295     return false;
5296
5297   return true;
5298 }
5299
5300
5301 bool
5302 gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
5303 {
5304   mpz_t nelems;
5305
5306   if (flag_coarray == GFC_FCOARRAY_NONE)
5307     {
5308       gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5309       return false;
5310     }
5311
5312   if (!coarray_check (coarray, 0))
5313     return false;
5314
5315   if (sub->rank != 1)
5316     {
5317       gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5318                 gfc_current_intrinsic_arg[1]->name, &sub->where);
5319       return false;
5320     }
5321
5322   if (gfc_array_size (sub, &nelems))
5323     {
5324       int corank = gfc_get_corank (coarray);
5325
5326       if (mpz_cmp_ui (nelems, corank) != 0)
5327         {
5328           gfc_error ("The number of array elements of the SUB argument to "
5329                      "IMAGE_INDEX at %L shall be %d (corank) not %d",
5330                      &sub->where, corank, (int) mpz_get_si (nelems));
5331           mpz_clear (nelems);
5332           return false;
5333         }
5334       mpz_clear (nelems);
5335     }
5336
5337   return true;
5338 }
5339
5340
5341 bool
5342 gfc_check_num_images (gfc_expr *distance, gfc_expr *failed)
5343 {
5344   if (flag_coarray == GFC_FCOARRAY_NONE)
5345     {
5346       gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5347       return false;
5348     }
5349
5350   if (distance)
5351     {
5352       if (!type_check (distance, 0, BT_INTEGER))
5353         return false;
5354
5355       if (!nonnegative_check ("DISTANCE", distance))
5356         return false;
5357
5358       if (!scalar_check (distance, 0))
5359         return false;
5360
5361       if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to "
5362                            "NUM_IMAGES at %L", &distance->where))
5363         return false;
5364     }
5365
5366    if (failed)
5367     {
5368       if (!type_check (failed, 1, BT_LOGICAL))
5369         return false;
5370
5371       if (!scalar_check (failed, 1))
5372         return false;
5373
5374       if (!gfc_notify_std (GFC_STD_F2018, "FAILED= argument to "
5375                            "NUM_IMAGES at %L", &failed->where))
5376         return false;
5377     }
5378
5379   return true;
5380 }
5381
5382
5383 bool
5384 gfc_check_team_number (gfc_expr *team)
5385 {
5386   if (flag_coarray == GFC_FCOARRAY_NONE)
5387     {
5388       gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5389       return false;
5390     }
5391
5392   if (team)
5393     {
5394       if (team->ts.type != BT_DERIVED
5395           || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
5396           || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
5397          {
5398            gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
5399                       "shall be of type TEAM_TYPE", &team->where);
5400            return false;
5401          }
5402     }
5403   else
5404     return true;
5405
5406   return true;
5407 }
5408
5409
5410 bool
5411 gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance)
5412 {
5413   if (flag_coarray == GFC_FCOARRAY_NONE)
5414     {
5415       gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5416       return false;
5417     }
5418
5419   if (coarray == NULL && dim == NULL && distance == NULL)
5420     return true;
5421
5422   if (dim != NULL && coarray == NULL)
5423     {
5424       gfc_error ("DIM argument without COARRAY argument not allowed for "
5425                  "THIS_IMAGE intrinsic at %L", &dim->where);
5426       return false;
5427     }
5428
5429   if (distance && (coarray || dim))
5430     {
5431       gfc_error ("The DISTANCE argument may not be specified together with the "
5432                  "COARRAY or DIM argument in intrinsic at %L",
5433                  &distance->where);
5434       return false;
5435     }
5436
5437   /* Assume that we have "this_image (distance)".  */
5438   if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER)
5439     {
5440       if (dim)
5441         {
5442           gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
5443                      &coarray->where);
5444           return false;
5445         }
5446       distance = coarray;
5447     }
5448
5449   if (distance)
5450     {
5451       if (!type_check (distance, 2, BT_INTEGER))
5452         return false;
5453
5454       if (!nonnegative_check ("DISTANCE", distance))
5455         return false;
5456
5457       if (!scalar_check (distance, 2))
5458         return false;
5459
5460       if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to "
5461                            "THIS_IMAGE at %L", &distance->where))
5462         return false;
5463
5464       return true;
5465     }
5466
5467   if (!coarray_check (coarray, 0))
5468     return false;
5469
5470   if (dim != NULL)
5471     {
5472       if (!dim_check (dim, 1, false))
5473        return false;
5474
5475       if (!dim_corank_check (dim, coarray))
5476        return false;
5477     }
5478
5479   return true;
5480 }
5481
5482 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
5483    by gfc_simplify_transfer.  Return false if we cannot do so.  */
5484
5485 bool
5486 gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
5487                               size_t *source_size, size_t *result_size,
5488                               size_t *result_length_p)
5489 {
5490   size_t result_elt_size;
5491
5492   if (source->expr_type == EXPR_FUNCTION)
5493     return false;
5494
5495   if (size && size->expr_type != EXPR_CONSTANT)
5496     return false;
5497
5498   /* Calculate the size of the source.  */
5499   *source_size = gfc_target_expr_size (source);
5500   if (*source_size == 0)
5501     return false;
5502
5503   /* Determine the size of the element.  */
5504   result_elt_size = gfc_element_size (mold);
5505   if (result_elt_size == 0)
5506     return false;
5507
5508   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
5509     {
5510       int result_length;
5511
5512       if (size)
5513         result_length = (size_t)mpz_get_ui (size->value.integer);
5514       else
5515         {
5516           result_length = *source_size / result_elt_size;
5517           if (result_length * result_elt_size < *source_size)
5518             result_length += 1;
5519         }
5520
5521       *result_size = result_length * result_elt_size;
5522       if (result_length_p)
5523         *result_length_p = result_length;
5524     }
5525   else
5526     *result_size = result_elt_size;
5527
5528   return true;
5529 }
5530
5531
5532 bool
5533 gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
5534 {
5535   size_t source_size;
5536   size_t result_size;
5537
5538   if (mold->ts.type == BT_HOLLERITH)
5539     {
5540       gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
5541                  " %s", &mold->where, gfc_basic_typename (BT_HOLLERITH));
5542       return false;
5543     }
5544
5545   if (size != NULL)
5546     {
5547       if (!type_check (size, 2, BT_INTEGER))
5548         return false;
5549
5550       if (!scalar_check (size, 2))
5551         return false;
5552
5553       if (!nonoptional_check (size, 2))
5554         return false;
5555     }
5556
5557   if (!warn_surprising)
5558     return true;
5559
5560   /* If we can't calculate the sizes, we cannot check any more.
5561      Return true for that case.  */
5562
5563   if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
5564                                      &result_size, NULL))
5565     return true;
5566
5567   if (source_size < result_size)
5568     gfc_warning (OPT_Wsurprising,
5569                  "Intrinsic TRANSFER at %L has partly undefined result: "
5570                  "source size %ld < result size %ld", &source->where,
5571                  (long) source_size, (long) result_size);
5572
5573   return true;
5574 }
5575
5576
5577 bool
5578 gfc_check_transpose (gfc_expr *matrix)
5579 {
5580   if (!rank_check (matrix, 0, 2))
5581     return false;
5582
5583   return true;
5584 }
5585
5586
5587 bool
5588 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5589 {
5590   if (!array_check (array, 0))
5591     return false;
5592
5593   if (!dim_check (dim, 1, false))
5594     return false;
5595
5596   if (!dim_rank_check (dim, array, 0))
5597     return false;
5598
5599   if (!kind_check (kind, 2, BT_INTEGER))
5600     return false;
5601   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
5602                                "with KIND argument at %L",
5603                                gfc_current_intrinsic, &kind->where))
5604     return false;
5605
5606   return true;
5607 }
5608
5609
5610 bool
5611 gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
5612 {
5613   if (flag_coarray == GFC_FCOARRAY_NONE)
5614     {
5615       gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5616       return false;
5617     }
5618
5619   if (!coarray_check (coarray, 0))
5620     return false;
5621
5622   if (dim != NULL)
5623     {
5624       if (!dim_check (dim, 1, false))
5625         return false;
5626
5627       if (!dim_corank_check (dim, coarray))
5628         return false;
5629     }
5630
5631   if (!kind_check (kind, 2, BT_INTEGER))
5632     return false;
5633
5634   return true;
5635 }
5636
5637
5638 bool
5639 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
5640 {
5641   mpz_t vector_size;
5642
5643   if (!rank_check (vector, 0, 1))
5644     return false;
5645
5646   if (!array_check (mask, 1))
5647     return false;
5648
5649   if (!type_check (mask, 1, BT_LOGICAL))
5650     return false;
5651
5652   if (!same_type_check (vector, 0, field, 2))
5653     return false;
5654
5655   if (mask->expr_type == EXPR_ARRAY
5656       && gfc_array_size (vector, &vector_size))
5657     {
5658       int mask_true_count = 0;
5659       gfc_constructor *mask_ctor;
5660       mask_ctor = gfc_constructor_first (mask->value.constructor);
5661       while (mask_ctor)
5662         {
5663           if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
5664             {
5665               mask_true_count = 0;
5666               break;
5667             }
5668
5669           if (mask_ctor->expr->value.logical)
5670             mask_true_count++;
5671
5672           mask_ctor = gfc_constructor_next (mask_ctor);
5673         }
5674
5675       if (mpz_get_si (vector_size) < mask_true_count)
5676         {
5677           gfc_error ("%qs argument of %qs intrinsic at %L must "
5678                      "provide at least as many elements as there "
5679                      "are .TRUE. values in %qs (%ld/%d)",
5680                      gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
5681                      &vector->where, gfc_current_intrinsic_arg[1]->name,
5682                      mpz_get_si (vector_size), mask_true_count);
5683           return false;
5684         }
5685
5686       mpz_clear (vector_size);
5687     }
5688
5689   if (mask->rank != field->rank && field->rank != 0)
5690     {
5691       gfc_error ("%qs argument of %qs intrinsic at %L must have "
5692                  "the same rank as %qs or be a scalar",
5693                  gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
5694                  &field->where, gfc_current_intrinsic_arg[1]->name);
5695       return false;
5696     }
5697
5698   if (mask->rank == field->rank)
5699     {
5700       int i;
5701       for (i = 0; i < field->rank; i++)
5702         if (! identical_dimen_shape (mask, i, field, i))
5703         {
5704           gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
5705                      "must have identical shape.",
5706                      gfc_current_intrinsic_arg[2]->name,
5707                      gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
5708                      &field->where);
5709         }
5710     }
5711
5712   return true;
5713 }
5714
5715
5716 bool
5717 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
5718 {
5719   if (!type_check (x, 0, BT_CHARACTER))
5720     return false;
5721
5722   if (!same_type_check (x, 0, y, 1))
5723     return false;
5724
5725   if (z != NULL && !type_check (z, 2, BT_LOGICAL))
5726     return false;
5727
5728   if (!kind_check (kind, 3, BT_INTEGER))
5729     return false;
5730   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
5731                                "with KIND argument at %L",
5732                                gfc_current_intrinsic, &kind->where))
5733     return false;
5734
5735   return true;
5736 }
5737
5738
5739 bool
5740 gfc_check_trim (gfc_expr *x)
5741 {
5742   if (!type_check (x, 0, BT_CHARACTER))
5743     return false;
5744
5745   if (!scalar_check (x, 0))
5746     return false;
5747
5748    return true;
5749 }
5750
5751
5752 bool
5753 gfc_check_ttynam (gfc_expr *unit)
5754 {
5755   if (!scalar_check (unit, 0))
5756     return false;
5757
5758   if (!type_check (unit, 0, BT_INTEGER))
5759     return false;
5760
5761   return true;
5762 }
5763
5764
5765 /************* Check functions for intrinsic subroutines *************/
5766
5767 bool
5768 gfc_check_cpu_time (gfc_expr *time)
5769 {
5770   if (!scalar_check (time, 0))
5771     return false;
5772
5773   if (!type_check (time, 0, BT_REAL))
5774     return false;
5775
5776   if (!variable_check (time, 0, false))
5777     return false;
5778
5779   return true;
5780 }
5781
5782
5783 bool
5784 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
5785                          gfc_expr *zone, gfc_expr *values)
5786 {
5787   if (date != NULL)
5788     {
5789       if (!type_check (date, 0, BT_CHARACTER))
5790         return false;
5791       if (!kind_value_check (date, 0, gfc_default_character_kind))
5792         return false;
5793       if (!scalar_check (date, 0))
5794         return false;
5795       if (!variable_check (date, 0, false))
5796         return false;
5797     }
5798
5799   if (time != NULL)
5800     {
5801       if (!type_check (time, 1, BT_CHARACTER))
5802         return false;
5803       if (!kind_value_check (time, 1, gfc_default_character_kind))
5804         return false;
5805       if (!scalar_check (time, 1))
5806         return false;
5807       if (!variable_check (time, 1, false))
5808         return false;
5809     }
5810
5811   if (zone != NULL)
5812     {
5813       if (!type_check (zone, 2, BT_CHARACTER))
5814         return false;
5815       if (!kind_value_check (zone, 2, gfc_default_character_kind))
5816         return false;
5817       if (!scalar_check (zone, 2))
5818         return false;
5819       if (!variable_check (zone, 2, false))
5820         return false;
5821     }
5822
5823   if (values != NULL)
5824     {
5825       if (!type_check (values, 3, BT_INTEGER))
5826         return false;
5827       if (!array_check (values, 3))
5828         return false;
5829       if (!rank_check (values, 3, 1))
5830         return false;
5831       if (!variable_check (values, 3, false))
5832         return false;
5833     }
5834
5835   return true;
5836 }
5837
5838
5839 bool
5840 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
5841                   gfc_expr *to, gfc_expr *topos)
5842 {
5843   if (!type_check (from, 0, BT_INTEGER))
5844     return false;
5845
5846   if (!type_check (frompos, 1, BT_INTEGER))
5847     return false;
5848
5849   if (!type_check (len, 2, BT_INTEGER))
5850     return false;
5851
5852   if (!same_type_check (from, 0, to, 3))
5853     return false;
5854
5855   if (!variable_check (to, 3, false))
5856     return false;
5857
5858   if (!type_check (topos, 4, BT_INTEGER))
5859     return false;
5860
5861   if (!nonnegative_check ("frompos", frompos))
5862     return false;
5863
5864   if (!nonnegative_check ("topos", topos))
5865     return false;
5866
5867   if (!nonnegative_check ("len", len))
5868     return false;
5869
5870   if (!less_than_bitsize2 ("from", from, "frompos", frompos, "len", len))
5871     return false;
5872
5873   if (!less_than_bitsize2 ("to", to, "topos", topos, "len", len))
5874     return false;
5875
5876   return true;
5877 }
5878
5879
5880 /* Check the arguments for RANDOM_INIT.  */
5881
5882 bool
5883 gfc_check_random_init (gfc_expr *repeatable, gfc_expr *image_distinct)
5884 {
5885   if (!type_check (repeatable, 0, BT_LOGICAL))
5886     return false;
5887
5888   if (!scalar_check (repeatable, 0))
5889     return false;
5890
5891   if (!type_check (image_distinct, 1, BT_LOGICAL))
5892     return false;
5893
5894   if (!scalar_check (image_distinct, 1))
5895     return false;
5896
5897   return true;
5898 }
5899
5900
5901 bool
5902 gfc_check_random_number (gfc_expr *harvest)
5903 {
5904   if (!type_check (harvest, 0, BT_REAL))
5905     return false;
5906
5907   if (!variable_check (harvest, 0, false))
5908     return false;
5909
5910   return true;
5911 }
5912
5913
5914 bool
5915 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
5916 {
5917   unsigned int nargs = 0, seed_size;
5918   locus *where = NULL;
5919   mpz_t put_size, get_size;
5920
5921   /* Keep the number of bytes in sync with master_state in
5922      libgfortran/intrinsics/random.c. +1 due to the integer p which is
5923      part of the state too.  */
5924   seed_size = 128 / gfc_default_integer_kind + 1;
5925
5926   if (size != NULL)
5927     {
5928       if (size->expr_type != EXPR_VARIABLE
5929           || !size->symtree->n.sym->attr.optional)
5930         nargs++;
5931
5932       if (!scalar_check (size, 0))
5933         return false;
5934
5935       if (!type_check (size, 0, BT_INTEGER))
5936         return false;
5937
5938       if (!variable_check (size, 0, false))
5939         return false;
5940
5941       if (!kind_value_check (size, 0, gfc_default_integer_kind))
5942         return false;
5943     }
5944
5945   if (put != NULL)
5946     {
5947       if (put->expr_type != EXPR_VARIABLE
5948           || !put->symtree->n.sym->attr.optional)
5949         {
5950           nargs++;
5951           where = &put->where;
5952         }
5953
5954       if (!array_check (put, 1))
5955         return false;
5956
5957       if (!rank_check (put, 1, 1))
5958         return false;
5959
5960       if (!type_check (put, 1, BT_INTEGER))
5961         return false;
5962
5963       if (!kind_value_check (put, 1, gfc_default_integer_kind))
5964         return false;
5965
5966       if (gfc_array_size (put, &put_size)
5967           && mpz_get_ui (put_size) < seed_size)
5968         gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5969                    "too small (%i/%i)",
5970                    gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
5971                    where, (int) mpz_get_ui (put_size), seed_size);
5972     }
5973
5974   if (get != NULL)
5975     {
5976       if (get->expr_type != EXPR_VARIABLE
5977           || !get->symtree->n.sym->attr.optional)
5978         {
5979           nargs++;
5980           where = &get->where;
5981         }
5982
5983       if (!array_check (get, 2))
5984         return false;
5985
5986       if (!rank_check (get, 2, 1))
5987         return false;
5988
5989       if (!type_check (get, 2, BT_INTEGER))
5990         return false;
5991
5992       if (!variable_check (get, 2, false))
5993         return false;
5994
5995       if (!kind_value_check (get, 2, gfc_default_integer_kind))
5996         return false;
5997
5998        if (gfc_array_size (get, &get_size)
5999            && mpz_get_ui (get_size) < seed_size)
6000         gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6001                    "too small (%i/%i)",
6002                    gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
6003                    where, (int) mpz_get_ui (get_size), seed_size);
6004     }
6005
6006   /* RANDOM_SEED may not have more than one non-optional argument.  */
6007   if (nargs > 1)
6008     gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
6009
6010   return true;
6011 }
6012
6013 bool
6014 gfc_check_fe_runtime_error (gfc_actual_arglist *a)
6015 {
6016   gfc_expr *e;
6017   size_t len, i;
6018   int num_percent, nargs;
6019
6020   e = a->expr;
6021   if (e->expr_type != EXPR_CONSTANT)
6022     return true;
6023
6024   len = e->value.character.length;
6025   if (e->value.character.string[len-1] != '\0')
6026     gfc_internal_error ("fe_runtime_error string must be null terminated");
6027
6028   num_percent = 0;
6029   for (i=0; i<len-1; i++)
6030     if (e->value.character.string[i] == '%')
6031       num_percent ++;
6032
6033   nargs = 0;
6034   for (; a; a = a->next)
6035     nargs ++;
6036
6037   if (nargs -1 != num_percent)
6038     gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
6039                         nargs, num_percent++);
6040
6041   return true;
6042 }
6043
6044 bool
6045 gfc_check_second_sub (gfc_expr *time)
6046 {
6047   if (!scalar_check (time, 0))
6048     return false;
6049
6050   if (!type_check (time, 0, BT_REAL))
6051     return false;
6052
6053   if (!kind_value_check (time, 0, 4))
6054     return false;
6055
6056   return true;
6057 }
6058
6059
6060 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
6061    variables in Fortran 95.  In Fortran 2003 and later, they can be of any
6062    kind, and COUNT_RATE can be of type real.  Note, count, count_rate, and
6063    count_max are all optional arguments */
6064
6065 bool
6066 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
6067                         gfc_expr *count_max)
6068 {
6069   if (count != NULL)
6070     {
6071       if (!scalar_check (count, 0))
6072         return false;
6073
6074       if (!type_check (count, 0, BT_INTEGER))
6075         return false;
6076
6077       if (count->ts.kind != gfc_default_integer_kind
6078           && !gfc_notify_std (GFC_STD_F2003, "COUNT argument to "
6079                               "SYSTEM_CLOCK at %L has non-default kind",
6080                               &count->where))
6081         return false;
6082
6083       if (!variable_check (count, 0, false))
6084         return false;
6085     }
6086
6087   if (count_rate != NULL)
6088     {
6089       if (!scalar_check (count_rate, 1))
6090         return false;
6091
6092       if (!variable_check (count_rate, 1, false))
6093         return false;
6094
6095       if (count_rate->ts.type == BT_REAL)
6096         {
6097           if (!gfc_notify_std (GFC_STD_F2003, "Real COUNT_RATE argument to "
6098                                "SYSTEM_CLOCK at %L", &count_rate->where))
6099             return false;
6100         }
6101       else
6102         {
6103           if (!type_check (count_rate, 1, BT_INTEGER))
6104             return false;
6105
6106           if (count_rate->ts.kind != gfc_default_integer_kind
6107               && !gfc_notify_std (GFC_STD_F2003, "COUNT_RATE argument to "
6108                                   "SYSTEM_CLOCK at %L has non-default kind",
6109                                   &count_rate->where))
6110             return false;
6111         }
6112
6113     }
6114
6115   if (count_max != NULL)
6116     {
6117       if (!scalar_check (count_max, 2))
6118         return false;
6119
6120       if (!type_check (count_max, 2, BT_INTEGER))
6121         return false;
6122
6123       if (count_max->ts.kind != gfc_default_integer_kind
6124           && !gfc_notify_std (GFC_STD_F2003, "COUNT_MAX argument to "
6125                               "SYSTEM_CLOCK at %L has non-default kind",
6126                               &count_max->where))
6127         return false;
6128
6129       if (!variable_check (count_max, 2, false))
6130         return false;
6131     }
6132
6133   return true;
6134 }
6135
6136
6137 bool
6138 gfc_check_irand (gfc_expr *x)
6139 {
6140   if (x == NULL)
6141     return true;
6142
6143   if (!scalar_check (x, 0))
6144     return false;
6145
6146   if (!type_check (x, 0, BT_INTEGER))
6147     return false;
6148
6149   if (!kind_value_check (x, 0, 4))
6150     return false;
6151
6152   return true;
6153 }
6154
6155
6156 bool
6157 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
6158 {
6159   if (!scalar_check (seconds, 0))
6160     return false;
6161   if (!type_check (seconds, 0, BT_INTEGER))
6162     return false;
6163
6164   if (!int_or_proc_check (handler, 1))
6165     return false;
6166   if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
6167     return false;
6168
6169   if (status == NULL)
6170     return true;
6171
6172   if (!scalar_check (status, 2))
6173     return false;
6174   if (!type_check (status, 2, BT_INTEGER))
6175     return false;
6176   if (!kind_value_check (status, 2, gfc_default_integer_kind))
6177     return false;
6178
6179   return true;
6180 }
6181
6182
6183 bool
6184 gfc_check_rand (gfc_expr *x)
6185 {
6186   if (x == NULL)
6187     return true;
6188
6189   if (!scalar_check (x, 0))
6190     return false;
6191
6192   if (!type_check (x, 0, BT_INTEGER))
6193     return false;
6194
6195   if (!kind_value_check (x, 0, 4))
6196     return false;
6197
6198   return true;
6199 }
6200
6201
6202 bool
6203 gfc_check_srand (gfc_expr *x)
6204 {
6205   if (!scalar_check (x, 0))
6206     return false;
6207
6208   if (!type_check (x, 0, BT_INTEGER))
6209     return false;
6210
6211   if (!kind_value_check (x, 0, 4))
6212     return false;
6213
6214   return true;
6215 }
6216
6217
6218 bool
6219 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
6220 {
6221   if (!scalar_check (time, 0))
6222     return false;
6223   if (!type_check (time, 0, BT_INTEGER))
6224     return false;
6225
6226   if (!type_check (result, 1, BT_CHARACTER))
6227     return false;
6228   if (!kind_value_check (result, 1, gfc_default_character_kind))
6229     return false;
6230
6231   return true;
6232 }
6233
6234
6235 bool
6236 gfc_check_dtime_etime (gfc_expr *x)
6237 {
6238   if (!array_check (x, 0))
6239     return false;
6240
6241   if (!rank_check (x, 0, 1))
6242     return false;
6243
6244   if (!variable_check (x, 0, false))
6245     return false;
6246
6247   if (!type_check (x, 0, BT_REAL))
6248     return false;
6249
6250   if (!kind_value_check (x, 0, 4))
6251     return false;
6252
6253   return true;
6254 }
6255
6256
6257 bool
6258 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
6259 {
6260   if (!array_check (values, 0))
6261     return false;
6262
6263   if (!rank_check (values, 0, 1))
6264     return false;
6265
6266   if (!variable_check (values, 0, false))
6267     return false;
6268
6269   if (!type_check (values, 0, BT_REAL))
6270     return false;
6271
6272   if (!kind_value_check (values, 0, 4))
6273     return false;
6274
6275   if (!scalar_check (time, 1))
6276     return false;
6277
6278   if (!type_check (time, 1, BT_REAL))
6279     return false;
6280
6281   if (!kind_value_check (time, 1, 4))
6282     return false;
6283
6284   return true;
6285 }
6286
6287
6288 bool
6289 gfc_check_fdate_sub (gfc_expr *date)
6290 {
6291   if (!type_check (date, 0, BT_CHARACTER))
6292     return false;
6293   if (!kind_value_check (date, 0, gfc_default_character_kind))
6294     return false;
6295
6296   return true;
6297 }
6298
6299
6300 bool
6301 gfc_check_gerror (gfc_expr *msg)
6302 {
6303   if (!type_check (msg, 0, BT_CHARACTER))
6304     return false;
6305   if (!kind_value_check (msg, 0, gfc_default_character_kind))
6306     return false;
6307
6308   return true;
6309 }
6310
6311
6312 bool
6313 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
6314 {
6315   if (!type_check (cwd, 0, BT_CHARACTER))
6316     return false;
6317   if (!kind_value_check (cwd, 0, gfc_default_character_kind))
6318     return false;
6319
6320   if (status == NULL)
6321     return true;
6322
6323   if (!scalar_check (status, 1))
6324     return false;
6325
6326   if (!type_check (status, 1, BT_INTEGER))
6327     return false;
6328
6329   return true;
6330 }
6331
6332
6333 bool
6334 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
6335 {
6336   if (!type_check (pos, 0, BT_INTEGER))
6337     return false;
6338
6339   if (pos->ts.kind > gfc_default_integer_kind)
6340     {
6341       gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
6342                  "not wider than the default kind (%d)",
6343                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
6344                  &pos->where, gfc_default_integer_kind);
6345       return false;
6346     }
6347
6348   if (!type_check (value, 1, BT_CHARACTER))
6349     return false;
6350   if (!kind_value_check (value, 1, gfc_default_character_kind))
6351     return false;
6352
6353   return true;
6354 }
6355
6356
6357 bool
6358 gfc_check_getlog (gfc_expr *msg)
6359 {
6360   if (!type_check (msg, 0, BT_CHARACTER))
6361     return false;
6362   if (!kind_value_check (msg, 0, gfc_default_character_kind))
6363     return false;
6364
6365   return true;
6366 }
6367
6368
6369 bool
6370 gfc_check_exit (gfc_expr *status)
6371 {
6372   if (status == NULL)
6373     return true;
6374
6375   if (!type_check (status, 0, BT_INTEGER))
6376     return false;
6377
6378   if (!scalar_check (status, 0))
6379     return false;
6380
6381   return true;
6382 }
6383
6384
6385 bool
6386 gfc_check_flush (gfc_expr *unit)
6387 {
6388   if (unit == NULL)
6389     return true;
6390
6391   if (!type_check (unit, 0, BT_INTEGER))
6392     return false;
6393
6394   if (!scalar_check (unit, 0))
6395     return false;
6396
6397   return true;
6398 }
6399
6400
6401 bool
6402 gfc_check_free (gfc_expr *i)
6403 {
6404   if (!type_check (i, 0, BT_INTEGER))
6405     return false;
6406
6407   if (!scalar_check (i, 0))
6408     return false;
6409
6410   return true;
6411 }
6412
6413
6414 bool
6415 gfc_check_hostnm (gfc_expr *name)
6416 {
6417   if (!type_check (name, 0, BT_CHARACTER))
6418     return false;
6419   if (!kind_value_check (name, 0, gfc_default_character_kind))
6420     return false;
6421
6422   return true;
6423 }
6424
6425
6426 bool
6427 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
6428 {
6429   if (!type_check (name, 0, BT_CHARACTER))
6430     return false;
6431   if (!kind_value_check (name, 0, gfc_default_character_kind))
6432     return false;
6433
6434   if (status == NULL)
6435     return true;
6436
6437   if (!scalar_check (status, 1))
6438     return false;
6439
6440   if (!type_check (status, 1, BT_INTEGER))
6441     return false;
6442
6443   return true;
6444 }
6445
6446
6447 bool
6448 gfc_check_itime_idate (gfc_expr *values)
6449 {
6450   if (!array_check (values, 0))
6451     return false;
6452
6453   if (!rank_check (values, 0, 1))
6454     return false;
6455
6456   if (!variable_check (values, 0, false))
6457     return false;
6458
6459   if (!type_check (values, 0, BT_INTEGER))
6460     return false;
6461
6462   if (!kind_value_check (values, 0, gfc_default_integer_kind))
6463     return false;
6464
6465   return true;
6466 }
6467
6468
6469 bool
6470 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
6471 {
6472   if (!type_check (time, 0, BT_INTEGER))
6473     return false;
6474
6475   if (!kind_value_check (time, 0, gfc_default_integer_kind))
6476     return false;
6477
6478   if (!scalar_check (time, 0))
6479     return false;
6480
6481   if (!array_check (values, 1))
6482     return false;
6483
6484   if (!rank_check (values, 1, 1))
6485     return false;
6486
6487   if (!variable_check (values, 1, false))
6488     return false;
6489
6490   if (!type_check (values, 1, BT_INTEGER))
6491     return false;
6492
6493   if (!kind_value_check (values, 1, gfc_default_integer_kind))
6494     return false;
6495
6496   return true;
6497 }
6498
6499
6500 bool
6501 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
6502 {
6503   if (!scalar_check (unit, 0))
6504     return false;
6505
6506   if (!type_check (unit, 0, BT_INTEGER))
6507     return false;
6508
6509   if (!type_check (name, 1, BT_CHARACTER))
6510     return false;
6511   if (!kind_value_check (name, 1, gfc_default_character_kind))
6512     return false;
6513
6514   return true;
6515 }
6516
6517
6518 bool
6519 gfc_check_isatty (gfc_expr *unit)
6520 {
6521   if (unit == NULL)
6522     return false;
6523
6524   if (!type_check (unit, 0, BT_INTEGER))
6525     return false;
6526
6527   if (!scalar_check (unit, 0))
6528     return false;
6529
6530   return true;
6531 }
6532
6533
6534 bool
6535 gfc_check_isnan (gfc_expr *x)
6536 {
6537   if (!type_check (x, 0, BT_REAL))
6538     return false;
6539
6540   return true;
6541 }
6542
6543
6544 bool
6545 gfc_check_perror (gfc_expr *string)
6546 {
6547   if (!type_check (string, 0, BT_CHARACTER))
6548     return false;
6549   if (!kind_value_check (string, 0, gfc_default_character_kind))
6550     return false;
6551
6552   return true;
6553 }
6554
6555
6556 bool
6557 gfc_check_umask (gfc_expr *mask)
6558 {
6559   if (!type_check (mask, 0, BT_INTEGER))
6560     return false;
6561
6562   if (!scalar_check (mask, 0))
6563     return false;
6564
6565   return true;
6566 }
6567
6568
6569 bool
6570 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
6571 {
6572   if (!type_check (mask, 0, BT_INTEGER))
6573     return false;
6574
6575   if (!scalar_check (mask, 0))
6576     return false;
6577
6578   if (old == NULL)
6579     return true;
6580
6581   if (!scalar_check (old, 1))
6582     return false;
6583
6584   if (!type_check (old, 1, BT_INTEGER))
6585     return false;
6586
6587   return true;
6588 }
6589
6590
6591 bool
6592 gfc_check_unlink (gfc_expr *name)
6593 {
6594   if (!type_check (name, 0, BT_CHARACTER))
6595     return false;
6596   if (!kind_value_check (name, 0, gfc_default_character_kind))
6597     return false;
6598
6599   return true;
6600 }
6601
6602
6603 bool
6604 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
6605 {
6606   if (!type_check (name, 0, BT_CHARACTER))
6607     return false;
6608   if (!kind_value_check (name, 0, gfc_default_character_kind))
6609     return false;
6610
6611   if (status == NULL)
6612     return true;
6613
6614   if (!scalar_check (status, 1))
6615     return false;
6616
6617   if (!type_check (status, 1, BT_INTEGER))
6618     return false;
6619
6620   return true;
6621 }
6622
6623
6624 bool
6625 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
6626 {
6627   if (!scalar_check (number, 0))
6628     return false;
6629   if (!type_check (number, 0, BT_INTEGER))
6630     return false;
6631
6632   if (!int_or_proc_check (handler, 1))
6633     return false;
6634   if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
6635     return false;
6636
6637   return true;
6638 }
6639
6640
6641 bool
6642 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
6643 {
6644   if (!scalar_check (number, 0))
6645     return false;
6646   if (!type_check (number, 0, BT_INTEGER))
6647     return false;
6648
6649   if (!int_or_proc_check (handler, 1))
6650     return false;
6651   if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
6652     return false;
6653
6654   if (status == NULL)
6655     return true;
6656
6657   if (!type_check (status, 2, BT_INTEGER))
6658     return false;
6659   if (!scalar_check (status, 2))
6660     return false;
6661
6662   return true;
6663 }
6664
6665
6666 bool
6667 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
6668 {
6669   if (!type_check (cmd, 0, BT_CHARACTER))
6670     return false;
6671   if (!kind_value_check (cmd, 0, gfc_default_character_kind))
6672     return false;
6673
6674   if (!scalar_check (status, 1))
6675     return false;
6676
6677   if (!type_check (status, 1, BT_INTEGER))
6678     return false;
6679
6680   if (!kind_value_check (status, 1, gfc_default_integer_kind))
6681     return false;
6682
6683   return true;
6684 }
6685
6686
6687 /* This is used for the GNU intrinsics AND, OR and XOR.  */
6688 bool
6689 gfc_check_and (gfc_expr *i, gfc_expr *j)
6690 {
6691   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
6692     {
6693       gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6694                  "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
6695                  gfc_current_intrinsic, &i->where);
6696       return false;
6697     }
6698
6699   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
6700     {
6701       gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6702                  "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
6703                  gfc_current_intrinsic, &j->where);
6704       return false;
6705     }
6706
6707   if (i->ts.type != j->ts.type)
6708     {
6709       gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
6710                  "have the same type", gfc_current_intrinsic_arg[0]->name,
6711                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
6712                  &j->where);
6713       return false;
6714     }
6715
6716   if (!scalar_check (i, 0))
6717     return false;
6718
6719   if (!scalar_check (j, 1))
6720     return false;
6721
6722   return true;
6723 }
6724
6725
6726 bool
6727 gfc_check_storage_size (gfc_expr *a, gfc_expr *kind)
6728 {
6729
6730   if (a->expr_type == EXPR_NULL)
6731     {
6732       gfc_error ("Intrinsic function NULL at %L cannot be an actual "
6733                  "argument to STORAGE_SIZE, because it returns a "
6734                  "disassociated pointer", &a->where);
6735       return false;
6736     }
6737
6738   if (a->ts.type == BT_ASSUMED)
6739     {
6740       gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
6741                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
6742                  &a->where);
6743       return false;
6744     }
6745
6746   if (a->ts.type == BT_PROCEDURE)
6747     {
6748       gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
6749                  "procedure", gfc_current_intrinsic_arg[0]->name,
6750                  gfc_current_intrinsic, &a->where);
6751       return false;
6752     }
6753
6754   if (kind == NULL)
6755     return true;
6756
6757   if (!type_check (kind, 1, BT_INTEGER))
6758     return false;
6759
6760   if (!scalar_check (kind, 1))
6761     return false;
6762
6763   if (kind->expr_type != EXPR_CONSTANT)
6764     {
6765       gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
6766                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
6767                  &kind->where);
6768       return false;
6769     }
6770
6771   return true;
6772 }