gcc/fortran/expr.c

   1 /* Routines for manipulation of expression nodes.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
   3    Free Software Foundation, Inc.
   4    Contributed by Andy Vaught
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include "gfortran.h"
  25 #include "arith.h"
  26 #include "match.h"
  27 #include "target-memory.h" /* for gfc_convert_boz */
  28
  29 /* Get a new expr node.  */
  30
  31 gfc_expr *
  32 gfc_get_expr (void)
  33 {
  34   gfc_expr *e;
  35
  36   e = XCNEW (gfc_expr);
  37   gfc_clear_ts (&e->ts);
  38   e->shape = NULL;
  39   e->ref = NULL;
  40   e->symtree = NULL;
  41   e->con_by_offset = NULL;
  42   return e;
  43 }
  44
  45
  46 /* Free an argument list and everything below it.  */
  47
  48 void
  49 gfc_free_actual_arglist (gfc_actual_arglist *a1)
  50 {
  51   gfc_actual_arglist *a2;
  52
  53   while (a1)
  54     {
  55       a2 = a1->next;
  56       gfc_free_expr (a1->expr);
  57       gfc_free (a1);
  58       a1 = a2;
  59     }
  60 }
  61
  62
  63 /* Copy an arglist structure and all of the arguments.  */
  64
  65 gfc_actual_arglist *
  66 gfc_copy_actual_arglist (gfc_actual_arglist *p)
  67 {
  68   gfc_actual_arglist *head, *tail, *new_arg;
  69
  70   head = tail = NULL;
  71
  72   for (; p; p = p->next)
  73     {
  74       new_arg = gfc_get_actual_arglist ();
  75       *new_arg = *p;
  76
  77       new_arg->expr = gfc_copy_expr (p->expr);
  78       new_arg->next = NULL;
  79
  80       if (head == NULL)
  81         head = new_arg;
  82       else
  83         tail->next = new_arg;
  84
  85       tail = new_arg;
  86     }
  87
  88   return head;
  89 }
  90
  91
  92 /* Free a list of reference structures.  */
  93
  94 void
  95 gfc_free_ref_list (gfc_ref *p)
  96 {
  97   gfc_ref *q;
  98   int i;
  99
 100   for (; p; p = q)
 101     {
 102       q = p->next;
 103
 104       switch (p->type)
 105         {
 106         case REF_ARRAY:
 107           for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
 108             {
 109               gfc_free_expr (p->u.ar.start[i]);
 110               gfc_free_expr (p->u.ar.end[i]);
 111               gfc_free_expr (p->u.ar.stride[i]);
 112             }
 113
 114           break;
 115
 116         case REF_SUBSTRING:
 117           gfc_free_expr (p->u.ss.start);
 118           gfc_free_expr (p->u.ss.end);
 119           break;
 120
 121         case REF_COMPONENT:
 122           break;
 123         }
 124
 125       gfc_free (p);
 126     }
 127 }
 128
 129
 130 /* Workhorse function for gfc_free_expr() that frees everything
 131    beneath an expression node, but not the node itself.  This is
 132    useful when we want to simplify a node and replace it with
 133    something else or the expression node belongs to another structure.  */
 134
 135 static void
 136 free_expr0 (gfc_expr *e)
 137 {
 138   int n;
 139
 140   switch (e->expr_type)
 141     {
 142     case EXPR_CONSTANT:
 143       /* Free any parts of the value that need freeing.  */
 144       switch (e->ts.type)
 145         {
 146         case BT_INTEGER:
 147           mpz_clear (e->value.integer);
 148           break;
 149
 150         case BT_REAL:
 151           mpfr_clear (e->value.real);
 152           break;
 153
 154         case BT_CHARACTER:
 155           gfc_free (e->value.character.string);
 156           break;
 157
 158         case BT_COMPLEX:
 159           mpc_clear (e->value.complex);
 160           break;
 161
 162         default:
 163           break;
 164         }
 165
 166       /* Free the representation.  */
 167       if (e->representation.string)
 168         gfc_free (e->representation.string);
 169
 170       break;
 171
 172     case EXPR_OP:
 173       if (e->value.op.op1 != NULL)
 174         gfc_free_expr (e->value.op.op1);
 175       if (e->value.op.op2 != NULL)
 176         gfc_free_expr (e->value.op.op2);
 177       break;
 178
 179     case EXPR_FUNCTION:
 180       gfc_free_actual_arglist (e->value.function.actual);
 181       break;
 182
 183     case EXPR_COMPCALL:
 184     case EXPR_PPC:
 185       gfc_free_actual_arglist (e->value.compcall.actual);
 186       break;
 187
 188     case EXPR_VARIABLE:
 189       break;
 190
 191     case EXPR_ARRAY:
 192     case EXPR_STRUCTURE:
 193       gfc_free_constructor (e->value.constructor);
 194       break;
 195
 196     case EXPR_SUBSTRING:
 197       gfc_free (e->value.character.string);
 198       break;
 199
 200     case EXPR_NULL:
 201       break;
 202
 203     default:
 204       gfc_internal_error ("free_expr0(): Bad expr type");
 205     }
 206
 207   /* Free a shape array.  */
 208   if (e->shape != NULL)
 209     {
 210       for (n = 0; n < e->rank; n++)
 211         mpz_clear (e->shape[n]);
 212
 213       gfc_free (e->shape);
 214     }
 215
 216   gfc_free_ref_list (e->ref);
 217
 218   memset (e, '\0', sizeof (gfc_expr));
 219 }
 220
 221
 222 /* Free an expression node and everything beneath it.  */
 223
 224 void
 225 gfc_free_expr (gfc_expr *e)
 226 {
 227   if (e == NULL)
 228     return;
 229   if (e->con_by_offset)
 230     splay_tree_delete (e->con_by_offset);
 231   free_expr0 (e);
 232   gfc_free (e);
 233 }
 234
 235
 236 /* Graft the *src expression onto the *dest subexpression.  */
 237
 238 void
 239 gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
 240 {
 241   free_expr0 (dest);
 242   *dest = *src;
 243   gfc_free (src);
 244 }
 245
 246
 247 /* Try to extract an integer constant from the passed expression node.
 248    Returns an error message or NULL if the result is set.  It is
 249    tempting to generate an error and return SUCCESS or FAILURE, but
 250    failure is OK for some callers.  */
 251
 252 const char *
 253 gfc_extract_int (gfc_expr *expr, int *result)
 254 {
 255   if (expr->expr_type != EXPR_CONSTANT)
 256     return _("Constant expression required at %C");
 257
 258   if (expr->ts.type != BT_INTEGER)
 259     return _("Integer expression required at %C");
 260
 261   if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
 262       || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
 263     {
 264       return _("Integer value too large in expression at %C");
 265     }
 266
 267   *result = (int) mpz_get_si (expr->value.integer);
 268
 269   return NULL;
 270 }
 271
 272
 273 /* Recursively copy a list of reference structures.  */
 274
 275 gfc_ref *
 276 gfc_copy_ref (gfc_ref *src)
 277 {
 278   gfc_array_ref *ar;
 279   gfc_ref *dest;
 280
 281   if (src == NULL)
 282     return NULL;
 283
 284   dest = gfc_get_ref ();
 285   dest->type = src->type;
 286
 287   switch (src->type)
 288     {
 289     case REF_ARRAY:
 290       ar = gfc_copy_array_ref (&src->u.ar);
 291       dest->u.ar = *ar;
 292       gfc_free (ar);
 293       break;
 294
 295     case REF_COMPONENT:
 296       dest->u.c = src->u.c;
 297       break;
 298
 299     case REF_SUBSTRING:
 300       dest->u.ss = src->u.ss;
 301       dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
 302       dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
 303       break;
 304     }
 305
 306   dest->next = gfc_copy_ref (src->next);
 307
 308   return dest;
 309 }
 310
 311
 312 /* Detect whether an expression has any vector index array references.  */
 313
 314 int
 315 gfc_has_vector_index (gfc_expr *e)
 316 {
 317   gfc_ref *ref;
 318   int i;
 319   for (ref = e->ref; ref; ref = ref->next)
 320     if (ref->type == REF_ARRAY)
 321       for (i = 0; i < ref->u.ar.dimen; i++)
 322         if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
 323           return 1;
 324   return 0;
 325 }
 326
 327
 328 /* Insert a reference to the component of the given name.
 329    Only to be used with CLASS containers.  */
 330
 331 void
 332 gfc_add_component_ref (gfc_expr *e, const char *name)
 333 {
 334   gfc_ref **tail = &(e->ref);
 335   gfc_ref *next = NULL;
 336   gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
 337   while (*tail != NULL)
 338     {
 339       if ((*tail)->type == REF_COMPONENT)
 340         derived = (*tail)->u.c.component->ts.u.derived;
 341       if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
 342         break;
 343       tail = &((*tail)->next);
 344     }
 345   if (*tail != NULL && strcmp (name, "$data") == 0)
 346     next = *tail;
 347   (*tail) = gfc_get_ref();
 348   (*tail)->next = next;
 349   (*tail)->type = REF_COMPONENT;
 350   (*tail)->u.c.sym = derived;
 351   (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
 352   gcc_assert((*tail)->u.c.component);
 353   if (!next)
 354     e->ts = (*tail)->u.c.component->ts;
 355 }
 356
 357
 358 /* Copy a shape array.  */
 359
 360 mpz_t *
 361 gfc_copy_shape (mpz_t *shape, int rank)
 362 {
 363   mpz_t *new_shape;
 364   int n;
 365
 366   if (shape == NULL)
 367     return NULL;
 368
 369   new_shape = gfc_get_shape (rank);
 370
 371   for (n = 0; n < rank; n++)
 372     mpz_init_set (new_shape[n], shape[n]);
 373
 374   return new_shape;
 375 }
 376
 377
 378 /* Copy a shape array excluding dimension N, where N is an integer
 379    constant expression.  Dimensions are numbered in fortran style --
 380    starting with ONE.
 381
 382    So, if the original shape array contains R elements
 383       { s1 ... sN-1  sN  sN+1 ... sR-1 sR}
 384    the result contains R-1 elements:
 385       { s1 ... sN-1  sN+1    ...  sR-1}
 386
 387    If anything goes wrong -- N is not a constant, its value is out
 388    of range -- or anything else, just returns NULL.  */
 389
 390 mpz_t *
 391 gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
 392 {
 393   mpz_t *new_shape, *s;
 394   int i, n;
 395
 396   if (shape == NULL
 397       || rank <= 1
 398       || dim == NULL
 399       || dim->expr_type != EXPR_CONSTANT
 400       || dim->ts.type != BT_INTEGER)
 401     return NULL;
 402
 403   n = mpz_get_si (dim->value.integer);
 404   n--; /* Convert to zero based index.  */
 405   if (n < 0 || n >= rank)
 406     return NULL;
 407
 408   s = new_shape = gfc_get_shape (rank - 1);
 409
 410   for (i = 0; i < rank; i++)
 411     {
 412       if (i == n)
 413         continue;
 414       mpz_init_set (*s, shape[i]);
 415       s++;
 416     }
 417
 418   return new_shape;
 419 }
 420
 421
 422 /* Given an expression pointer, return a copy of the expression.  This
 423    subroutine is recursive.  */
 424
 425 gfc_expr *
 426 gfc_copy_expr (gfc_expr *p)
 427 {
 428   gfc_expr *q;
 429   gfc_char_t *s;
 430   char *c;
 431
 432   if (p == NULL)
 433     return NULL;
 434
 435   q = gfc_get_expr ();
 436   *q = *p;
 437
 438   switch (q->expr_type)
 439     {
 440     case EXPR_SUBSTRING:
 441       s = gfc_get_wide_string (p->value.character.length + 1);
 442       q->value.character.string = s;
 443       memcpy (s, p->value.character.string,
 444               (p->value.character.length + 1) * sizeof (gfc_char_t));
 445       break;
 446
 447     case EXPR_CONSTANT:
 448       /* Copy target representation, if it exists.  */
 449       if (p->representation.string)
 450         {
 451           c = XCNEWVEC (char, p->representation.length + 1);
 452           q->representation.string = c;
 453           memcpy (c, p->representation.string, (p->representation.length + 1));
 454         }
 455
 456       /* Copy the values of any pointer components of p->value.  */
 457       switch (q->ts.type)
 458         {
 459         case BT_INTEGER:
 460           mpz_init_set (q->value.integer, p->value.integer);
 461           break;
 462
 463         case BT_REAL:
 464           gfc_set_model_kind (q->ts.kind);
 465           mpfr_init (q->value.real);
 466           mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
 467           break;
 468
 469         case BT_COMPLEX:
 470           gfc_set_model_kind (q->ts.kind);
 471           mpc_init2 (q->value.complex, mpfr_get_default_prec());
 472           mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
 473           break;
 474
 475         case BT_CHARACTER:
 476           if (p->representation.string)
 477             q->value.character.string
 478               = gfc_char_to_widechar (q->representation.string);
 479           else
 480             {
 481               s = gfc_get_wide_string (p->value.character.length + 1);
 482               q->value.character.string = s;
 483
 484               /* This is the case for the C_NULL_CHAR named constant.  */
 485               if (p->value.character.length == 0
 486                   && (p->ts.is_c_interop || p->ts.is_iso_c))
 487                 {
 488                   *s = '\0';
 489                   /* Need to set the length to 1 to make sure the NUL
 490                      terminator is copied.  */
 491                   q->value.character.length = 1;
 492                 }
 493               else
 494                 memcpy (s, p->value.character.string,
 495                         (p->value.character.length + 1) * sizeof (gfc_char_t));
 496             }
 497           break;
 498
 499         case BT_HOLLERITH:
 500         case BT_LOGICAL:
 501         case BT_DERIVED:
 502         case BT_CLASS:
 503           break;                /* Already done.  */
 504
 505         case BT_PROCEDURE:
 506         case BT_VOID:
 507            /* Should never be reached.  */
 508         case BT_UNKNOWN:
 509           gfc_internal_error ("gfc_copy_expr(): Bad expr node");
 510           /* Not reached.  */
 511         }
 512
 513       break;
 514
 515     case EXPR_OP:
 516       switch (q->value.op.op)
 517         {
 518         case INTRINSIC_NOT:
 519         case INTRINSIC_PARENTHESES:
 520         case INTRINSIC_UPLUS:
 521         case INTRINSIC_UMINUS:
 522           q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
 523           break;
 524
 525         default:                /* Binary operators.  */
 526           q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
 527           q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
 528           break;
 529         }
 530
 531       break;
 532
 533     case EXPR_FUNCTION:
 534       q->value.function.actual =
 535         gfc_copy_actual_arglist (p->value.function.actual);
 536       break;
 537
 538     case EXPR_COMPCALL:
 539     case EXPR_PPC:
 540       q->value.compcall.actual =
 541         gfc_copy_actual_arglist (p->value.compcall.actual);
 542       q->value.compcall.tbp = p->value.compcall.tbp;
 543       break;
 544
 545     case EXPR_STRUCTURE:
 546     case EXPR_ARRAY:
 547       q->value.constructor = gfc_copy_constructor (p->value.constructor);
 548       break;
 549
 550     case EXPR_VARIABLE:
 551     case EXPR_NULL:
 552       break;
 553     }
 554
 555   q->shape = gfc_copy_shape (p->shape, p->rank);
 556
 557   q->ref = gfc_copy_ref (p->ref);
 558
 559   return q;
 560 }
 561
 562
 563 /* Return the maximum kind of two expressions.  In general, higher
 564    kind numbers mean more precision for numeric types.  */
 565
 566 int
 567 gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
 568 {
 569   return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
 570 }
 571
 572
 573 /* Returns nonzero if the type is numeric, zero otherwise.  */
 574
 575 static int
 576 numeric_type (bt type)
 577 {
 578   return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
 579 }
 580
 581
 582 /* Returns nonzero if the typespec is a numeric type, zero otherwise.  */
 583
 584 int
 585 gfc_numeric_ts (gfc_typespec *ts)
 586 {
 587   return numeric_type (ts->type);
 588 }
 589
 590
 591 /* Returns an expression node that is an integer constant.  */
 592
 593 gfc_expr *
 594 gfc_int_expr (int i)
 595 {
 596   gfc_expr *p;
 597
 598   p = gfc_get_expr ();
 599
 600   p->expr_type = EXPR_CONSTANT;
 601   p->ts.type = BT_INTEGER;
 602   p->ts.kind = gfc_default_integer_kind;
 603
 604   p->where = gfc_current_locus;
 605   mpz_init_set_si (p->value.integer, i);
 606
 607   return p;
 608 }
 609
 610
 611 /* Returns an expression node that is a logical constant.  */
 612
 613 gfc_expr *
 614 gfc_logical_expr (int i, locus *where)
 615 {
 616   gfc_expr *p;
 617
 618   p = gfc_get_expr ();
 619
 620   p->expr_type = EXPR_CONSTANT;
 621   p->ts.type = BT_LOGICAL;
 622   p->ts.kind = gfc_default_logical_kind;
 623
 624   if (where == NULL)
 625     where = &gfc_current_locus;
 626   p->where = *where;
 627   p->value.logical = i;
 628
 629   return p;
 630 }
 631
 632
 633 /* Return an expression node with an optional argument list attached.
 634    A variable number of gfc_expr pointers are strung together in an
 635    argument list with a NULL pointer terminating the list.  */
 636
 637 gfc_expr *
 638 gfc_build_conversion (gfc_expr *e)
 639 {
 640   gfc_expr *p;
 641
 642   p = gfc_get_expr ();
 643   p->expr_type = EXPR_FUNCTION;
 644   p->symtree = NULL;
 645   p->value.function.actual = NULL;
 646
 647   p->value.function.actual = gfc_get_actual_arglist ();
 648   p->value.function.actual->expr = e;
 649
 650   return p;
 651 }
 652
 653
 654 /* Given an expression node with some sort of numeric binary
 655    expression, insert type conversions required to make the operands
 656    have the same type.
 657
 658    The exception is that the operands of an exponential don't have to
 659    have the same type.  If possible, the base is promoted to the type
 660    of the exponent.  For example, 1**2.3 becomes 1.0**2.3, but
 661    1.0**2 stays as it is.  */
 662
 663 void
 664 gfc_type_convert_binary (gfc_expr *e)
 665 {
 666   gfc_expr *op1, *op2;
 667
 668   op1 = e->value.op.op1;
 669   op2 = e->value.op.op2;
 670
 671   if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
 672     {
 673       gfc_clear_ts (&e->ts);
 674       return;
 675     }
 676
 677   /* Kind conversions of same type.  */
 678   if (op1->ts.type == op2->ts.type)
 679     {
 680       if (op1->ts.kind == op2->ts.kind)
 681         {
 682           /* No type conversions.  */
 683           e->ts = op1->ts;
 684           goto done;
 685         }
 686
 687       if (op1->ts.kind > op2->ts.kind)
 688         gfc_convert_type (op2, &op1->ts, 2);
 689       else
 690         gfc_convert_type (op1, &op2->ts, 2);
 691
 692       e->ts = op1->ts;
 693       goto done;
 694     }
 695
 696   /* Integer combined with real or complex.  */
 697   if (op2->ts.type == BT_INTEGER)
 698     {
 699       e->ts = op1->ts;
 700
 701       /* Special case for ** operator.  */
 702       if (e->value.op.op == INTRINSIC_POWER)
 703         goto done;
 704
 705       gfc_convert_type (e->value.op.op2, &e->ts, 2);
 706       goto done;
 707     }
 708
 709   if (op1->ts.type == BT_INTEGER)
 710     {
 711       e->ts = op2->ts;
 712       gfc_convert_type (e->value.op.op1, &e->ts, 2);
 713       goto done;
 714     }
 715
 716   /* Real combined with complex.  */
 717   e->ts.type = BT_COMPLEX;
 718   if (op1->ts.kind > op2->ts.kind)
 719     e->ts.kind = op1->ts.kind;
 720   else
 721     e->ts.kind = op2->ts.kind;
 722   if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
 723     gfc_convert_type (e->value.op.op1, &e->ts, 2);
 724   if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
 725     gfc_convert_type (e->value.op.op2, &e->ts, 2);
 726
 727 done:
 728   return;
 729 }
 730
 731
 732 static match
 733 check_specification_function (gfc_expr *e)
 734 {
 735   gfc_symbol *sym;
 736
 737   if (!e->symtree)
 738     return MATCH_NO;
 739
 740   sym = e->symtree->n.sym;
 741
 742   /* F95, 7.1.6.2; F2003, 7.1.7  */
 743   if (sym
 744       && sym->attr.function
 745       && sym->attr.pure
 746       && !sym->attr.intrinsic
 747       && !sym->attr.recursive
 748       && sym->attr.proc != PROC_INTERNAL
 749       && sym->attr.proc != PROC_ST_FUNCTION
 750       && sym->attr.proc != PROC_UNKNOWN
 751       && sym->formal == NULL)
 752     return MATCH_YES;
 753
 754   return MATCH_NO;
 755 }
 756
 757 /* Function to determine if an expression is constant or not.  This
 758    function expects that the expression has already been simplified.  */
 759
 760 int
 761 gfc_is_constant_expr (gfc_expr *e)
 762 {
 763   gfc_constructor *c;
 764   gfc_actual_arglist *arg;
 765   int rv;
 766
 767   if (e == NULL)
 768     return 1;
 769
 770   switch (e->expr_type)
 771     {
 772     case EXPR_OP:
 773       rv = (gfc_is_constant_expr (e->value.op.op1)
 774             && (e->value.op.op2 == NULL
 775                 || gfc_is_constant_expr (e->value.op.op2)));
 776       break;
 777
 778     case EXPR_VARIABLE:
 779       rv = 0;
 780       break;
 781
 782     case EXPR_FUNCTION:
 783       /* Specification functions are constant.  */
 784       if (check_specification_function (e) == MATCH_YES)
 785         {
 786           rv = 1;
 787           break;
 788         }
 789
 790       /* Call to intrinsic with at least one argument.  */
 791       rv = 0;
 792       if (e->value.function.isym && e->value.function.actual)
 793         {
 794           for (arg = e->value.function.actual; arg; arg = arg->next)
 795             {
 796               if (!gfc_is_constant_expr (arg->expr))
 797                 break;
 798             }
 799           if (arg == NULL)
 800             rv = 1;
 801         }
 802       break;
 803
 804     case EXPR_CONSTANT:
 805     case EXPR_NULL:
 806       rv = 1;
 807       break;
 808
 809     case EXPR_SUBSTRING:
 810       rv = e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
 811                               && gfc_is_constant_expr (e->ref->u.ss.end));
 812       break;
 813
 814     case EXPR_STRUCTURE:
 815       rv = 0;
 816       for (c = e->value.constructor; c; c = c->next)
 817         if (!gfc_is_constant_expr (c->expr))
 818           break;
 819
 820       if (c == NULL)
 821         rv = 1;
 822       break;
 823
 824     case EXPR_ARRAY:
 825       rv = gfc_constant_ac (e);
 826       break;
 827
 828     default:
 829       gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
 830     }
 831
 832   return rv;
 833 }
 834
 835
 836 /* Is true if an array reference is followed by a component or substring
 837    reference.  */
 838 bool
 839 is_subref_array (gfc_expr * e)
 840 {
 841   gfc_ref * ref;
 842   bool seen_array;
 843
 844   if (e->expr_type != EXPR_VARIABLE)
 845     return false;
 846
 847   if (e->symtree->n.sym->attr.subref_array_pointer)
 848     return true;
 849
 850   seen_array = false;
 851   for (ref = e->ref; ref; ref = ref->next)
 852     {
 853       if (ref->type == REF_ARRAY
 854             && ref->u.ar.type != AR_ELEMENT)
 855         seen_array = true;
 856
 857       if (seen_array
 858             && ref->type != REF_ARRAY)
 859         return seen_array;
 860     }
 861   return false;
 862 }
 863
 864
 865 /* Try to collapse intrinsic expressions.  */
 866
 867 static gfc_try
 868 simplify_intrinsic_op (gfc_expr *p, int type)
 869 {
 870   gfc_intrinsic_op op;
 871   gfc_expr *op1, *op2, *result;
 872
 873   if (p->value.op.op == INTRINSIC_USER)
 874     return SUCCESS;
 875
 876   op1 = p->value.op.op1;
 877   op2 = p->value.op.op2;
 878   op  = p->value.op.op;
 879
 880   if (gfc_simplify_expr (op1, type) == FAILURE)
 881     return FAILURE;
 882   if (gfc_simplify_expr (op2, type) == FAILURE)
 883     return FAILURE;
 884
 885   if (!gfc_is_constant_expr (op1)
 886       || (op2 != NULL && !gfc_is_constant_expr (op2)))
 887     return SUCCESS;
 888
 889   /* Rip p apart.  */
 890   p->value.op.op1 = NULL;
 891   p->value.op.op2 = NULL;
 892
 893   switch (op)
 894     {
 895     case INTRINSIC_PARENTHESES:
 896       result = gfc_parentheses (op1);
 897       break;
 898
 899     case INTRINSIC_UPLUS:
 900       result = gfc_uplus (op1);
 901       break;
 902
 903     case INTRINSIC_UMINUS:
 904       result = gfc_uminus (op1);
 905       break;
 906
 907     case INTRINSIC_PLUS:
 908       result = gfc_add (op1, op2);
 909       break;
 910
 911     case INTRINSIC_MINUS:
 912       result = gfc_subtract (op1, op2);
 913       break;
 914
 915     case INTRINSIC_TIMES:
 916       result = gfc_multiply (op1, op2);
 917       break;
 918
 919     case INTRINSIC_DIVIDE:
 920       result = gfc_divide (op1, op2);
 921       break;
 922
 923     case INTRINSIC_POWER:
 924       result = gfc_power (op1, op2);
 925       break;
 926
 927     case INTRINSIC_CONCAT:
 928       result = gfc_concat (op1, op2);
 929       break;
 930
 931     case INTRINSIC_EQ:
 932     case INTRINSIC_EQ_OS:
 933       result = gfc_eq (op1, op2, op);
 934       break;
 935
 936     case INTRINSIC_NE:
 937     case INTRINSIC_NE_OS:
 938       result = gfc_ne (op1, op2, op);
 939       break;
 940
 941     case INTRINSIC_GT:
 942     case INTRINSIC_GT_OS:
 943       result = gfc_gt (op1, op2, op);
 944       break;
 945
 946     case INTRINSIC_GE:
 947     case INTRINSIC_GE_OS:
 948       result = gfc_ge (op1, op2, op);
 949       break;
 950
 951     case INTRINSIC_LT:
 952     case INTRINSIC_LT_OS:
 953       result = gfc_lt (op1, op2, op);
 954       break;
 955
 956     case INTRINSIC_LE:
 957     case INTRINSIC_LE_OS:
 958       result = gfc_le (op1, op2, op);
 959       break;
 960
 961     case INTRINSIC_NOT:
 962       result = gfc_not (op1);
 963       break;
 964
 965     case INTRINSIC_AND:
 966       result = gfc_and (op1, op2);
 967       break;
 968
 969     case INTRINSIC_OR:
 970       result = gfc_or (op1, op2);
 971       break;
 972
 973     case INTRINSIC_EQV:
 974       result = gfc_eqv (op1, op2);
 975       break;
 976
 977     case INTRINSIC_NEQV:
 978       result = gfc_neqv (op1, op2);
 979       break;
 980
 981     default:
 982       gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
 983     }
 984
 985   if (result == NULL)
 986     {
 987       gfc_free_expr (op1);
 988       gfc_free_expr (op2);
 989       return FAILURE;
 990     }
 991
 992   result->rank = p->rank;
 993   result->where = p->where;
 994   gfc_replace_expr (p, result);
 995
 996   return SUCCESS;
 997 }
 998
 999
1000 /* Subroutine to simplify constructor expressions.  Mutually recursive
1001    with gfc_simplify_expr().  */
1002
1003 static gfc_try
1004 simplify_constructor (gfc_constructor *c, int type)
1005 {
1006   gfc_expr *p;
1007
1008   for (; c; c = c->next)
1009     {
1010       if (c->iterator
1011           && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
1012               || gfc_simplify_expr (c->iterator->end, type) == FAILURE
1013               || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
1014         return FAILURE;
1015
1016       if (c->expr)
1017         {
1018           /* Try and simplify a copy.  Replace the original if successful
1019              but keep going through the constructor at all costs.  Not
1020              doing so can make a dog's dinner of complicated things.  */
1021           p = gfc_copy_expr (c->expr);
1022
1023           if (gfc_simplify_expr (p, type) == FAILURE)
1024             {
1025               gfc_free_expr (p);
1026               continue;
1027             }
1028
1029           gfc_replace_expr (c->expr, p);
1030         }
1031     }
1032
1033   return SUCCESS;
1034 }
1035
1036
1037 /* Pull a single array element out of an array constructor.  */
1038
1039 static gfc_try
1040 find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
1041                     gfc_constructor **rval)
1042 {
1043   unsigned long nelemen;
1044   int i;
1045   mpz_t delta;
1046   mpz_t offset;
1047   mpz_t span;
1048   mpz_t tmp;
1049   gfc_expr *e;
1050   gfc_try t;
1051
1052   t = SUCCESS;
1053   e = NULL;
1054
1055   mpz_init_set_ui (offset, 0);
1056   mpz_init (delta);
1057   mpz_init (tmp);
1058   mpz_init_set_ui (span, 1);
1059   for (i = 0; i < ar->dimen; i++)
1060     {
1061       if (gfc_reduce_init_expr (ar->as->lower[i]) == FAILURE
1062           || gfc_reduce_init_expr (ar->as->upper[i]) == FAILURE)
1063         {
1064           t = FAILURE;
1065           cons = NULL;
1066           goto depart;
1067         }
1068
1069       e = gfc_copy_expr (ar->start[i]);
1070       if (e->expr_type != EXPR_CONSTANT)
1071         {
1072           cons = NULL;
1073           goto depart;
1074         }
1075
1076       gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT
1077                   && ar->as->lower[i]->expr_type == EXPR_CONSTANT);
1078
1079       /* Check the bounds.  */
1080       if ((ar->as->upper[i]
1081            && mpz_cmp (e->value.integer,
1082                        ar->as->upper[i]->value.integer) > 0)
1083           || (mpz_cmp (e->value.integer,
1084                        ar->as->lower[i]->value.integer) < 0))
1085         {
1086           gfc_error ("Index in dimension %d is out of bounds "
1087                      "at %L", i + 1, &ar->c_where[i]);
1088           cons = NULL;
1089           t = FAILURE;
1090           goto depart;
1091         }
1092
1093       mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1094       mpz_mul (delta, delta, span);
1095       mpz_add (offset, offset, delta);
1096
1097       mpz_set_ui (tmp, 1);
1098       mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1099       mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1100       mpz_mul (span, span, tmp);
1101     }
1102
1103   for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
1104     {
1105       if (cons)
1106         {
1107           if (cons->iterator)
1108             {
1109               cons = NULL;
1110               goto depart;
1111             }
1112           cons = cons->next;
1113         }
1114     }
1115
1116 depart:
1117   mpz_clear (delta);
1118   mpz_clear (offset);
1119   mpz_clear (span);
1120   mpz_clear (tmp);
1121   if (e)
1122     gfc_free_expr (e);
1123   *rval = cons;
1124   return t;
1125 }
1126
1127
1128 /* Find a component of a structure constructor.  */
1129
1130 static gfc_constructor *
1131 find_component_ref (gfc_constructor *cons, gfc_ref *ref)
1132 {
1133   gfc_component *comp;
1134   gfc_component *pick;
1135
1136   comp = ref->u.c.sym->components;
1137   pick = ref->u.c.component;
1138   while (comp != pick)
1139     {
1140       comp = comp->next;
1141       cons = cons->next;
1142     }
1143
1144   return cons;
1145 }
1146
1147
1148 /* Replace an expression with the contents of a constructor, removing
1149    the subobject reference in the process.  */
1150
1151 static void
1152 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
1153 {
1154   gfc_expr *e;
1155
1156   e = cons->expr;
1157   cons->expr = NULL;
1158   e->ref = p->ref->next;
1159   p->ref->next =  NULL;
1160   gfc_replace_expr (p, e);
1161 }
1162
1163
1164 /* Pull an array section out of an array constructor.  */
1165
1166 static gfc_try
1167 find_array_section (gfc_expr *expr, gfc_ref *ref)
1168 {
1169   int idx;
1170   int rank;
1171   int d;
1172   int shape_i;
1173   long unsigned one = 1;
1174   bool incr_ctr;
1175   mpz_t start[GFC_MAX_DIMENSIONS];
1176   mpz_t end[GFC_MAX_DIMENSIONS];
1177   mpz_t stride[GFC_MAX_DIMENSIONS];
1178   mpz_t delta[GFC_MAX_DIMENSIONS];
1179   mpz_t ctr[GFC_MAX_DIMENSIONS];
1180   mpz_t delta_mpz;
1181   mpz_t tmp_mpz;
1182   mpz_t nelts;
1183   mpz_t ptr;
1184   mpz_t index;
1185   gfc_constructor *cons;
1186   gfc_constructor *base;
1187   gfc_expr *begin;
1188   gfc_expr *finish;
1189   gfc_expr *step;
1190   gfc_expr *upper;
1191   gfc_expr *lower;
1192   gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
1193   gfc_try t;
1194
1195   t = SUCCESS;
1196
1197   base = expr->value.constructor;
1198   expr->value.constructor = NULL;
1199
1200   rank = ref->u.ar.as->rank;
1201
1202   if (expr->shape == NULL)
1203     expr->shape = gfc_get_shape (rank);
1204
1205   mpz_init_set_ui (delta_mpz, one);
1206   mpz_init_set_ui (nelts, one);
1207   mpz_init (tmp_mpz);
1208
1209   /* Do the initialization now, so that we can cleanup without
1210      keeping track of where we were.  */
1211   for (d = 0; d < rank; d++)
1212     {
1213       mpz_init (delta[d]);
1214       mpz_init (start[d]);
1215       mpz_init (end[d]);
1216       mpz_init (ctr[d]);
1217       mpz_init (stride[d]);
1218       vecsub[d] = NULL;
1219     }
1220
1221   /* Build the counters to clock through the array reference.  */
1222   shape_i = 0;
1223   for (d = 0; d < rank; d++)
1224     {
1225       /* Make this stretch of code easier on the eye!  */
1226       begin = ref->u.ar.start[d];
1227       finish = ref->u.ar.end[d];
1228       step = ref->u.ar.stride[d];
1229       lower = ref->u.ar.as->lower[d];
1230       upper = ref->u.ar.as->upper[d];
1231
1232       if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR)  /* Vector subscript.  */
1233         {
1234           gcc_assert (begin);
1235
1236           if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1237             {
1238               t = FAILURE;
1239               goto cleanup;
1240             }
1241
1242           gcc_assert (begin->rank == 1);
1243           /* Zero-sized arrays have no shape and no elements, stop early.  */
1244           if (!begin->shape)
1245             {
1246               mpz_init_set_ui (nelts, 0);
1247               break;
1248             }
1249
1250           vecsub[d] = begin->value.constructor;
1251           mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1252           mpz_mul (nelts, nelts, begin->shape[0]);
1253           mpz_set (expr->shape[shape_i++], begin->shape[0]);
1254
1255           /* Check bounds.  */
1256           for (c = vecsub[d]; c; c = c->next)
1257             {
1258               if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
1259                   || mpz_cmp (c->expr->value.integer,
1260                               lower->value.integer) < 0)
1261                 {
1262                   gfc_error ("index in dimension %d is out of bounds "
1263                              "at %L", d + 1, &ref->u.ar.c_where[d]);
1264                   t = FAILURE;
1265                   goto cleanup;
1266                 }
1267             }
1268         }
1269       else
1270         {
1271           if ((begin && begin->expr_type != EXPR_CONSTANT)
1272               || (finish && finish->expr_type != EXPR_CONSTANT)
1273               || (step && step->expr_type != EXPR_CONSTANT))
1274             {
1275               t = FAILURE;
1276               goto cleanup;
1277             }
1278
1279           /* Obtain the stride.  */
1280           if (step)
1281             mpz_set (stride[d], step->value.integer);
1282           else
1283             mpz_set_ui (stride[d], one);
1284
1285           if (mpz_cmp_ui (stride[d], 0) == 0)
1286             mpz_set_ui (stride[d], one);
1287
1288           /* Obtain the start value for the index.  */
1289           if (begin)
1290             mpz_set (start[d], begin->value.integer);
1291           else
1292             mpz_set (start[d], lower->value.integer);
1293
1294           mpz_set (ctr[d], start[d]);
1295
1296           /* Obtain the end value for the index.  */
1297           if (finish)
1298             mpz_set (end[d], finish->value.integer);
1299           else
1300             mpz_set (end[d], upper->value.integer);
1301
1302           /* Separate 'if' because elements sometimes arrive with
1303              non-null end.  */
1304           if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1305             mpz_set (end [d], begin->value.integer);
1306
1307           /* Check the bounds.  */
1308           if (mpz_cmp (ctr[d], upper->value.integer) > 0
1309               || mpz_cmp (end[d], upper->value.integer) > 0
1310               || mpz_cmp (ctr[d], lower->value.integer) < 0
1311               || mpz_cmp (end[d], lower->value.integer) < 0)
1312             {
1313               gfc_error ("index in dimension %d is out of bounds "
1314                          "at %L", d + 1, &ref->u.ar.c_where[d]);
1315               t = FAILURE;
1316               goto cleanup;
1317             }
1318
1319           /* Calculate the number of elements and the shape.  */
1320           mpz_set (tmp_mpz, stride[d]);
1321           mpz_add (tmp_mpz, end[d], tmp_mpz);
1322           mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1323           mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1324           mpz_mul (nelts, nelts, tmp_mpz);
1325
1326           /* An element reference reduces the rank of the expression; don't
1327              add anything to the shape array.  */
1328           if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1329             mpz_set (expr->shape[shape_i++], tmp_mpz);
1330         }
1331
1332       /* Calculate the 'stride' (=delta) for conversion of the
1333          counter values into the index along the constructor.  */
1334       mpz_set (delta[d], delta_mpz);
1335       mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1336       mpz_add_ui (tmp_mpz, tmp_mpz, one);
1337       mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1338     }
1339
1340   mpz_init (index);
1341   mpz_init (ptr);
1342   cons = base;
1343
1344   /* Now clock through the array reference, calculating the index in
1345      the source constructor and transferring the elements to the new
1346      constructor.  */
1347   for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1348     {
1349       if (ref->u.ar.offset)
1350         mpz_set (ptr, ref->u.ar.offset->value.integer);
1351       else
1352         mpz_init_set_ui (ptr, 0);
1353
1354       incr_ctr = true;
1355       for (d = 0; d < rank; d++)
1356         {
1357           mpz_set (tmp_mpz, ctr[d]);
1358           mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1359           mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1360           mpz_add (ptr, ptr, tmp_mpz);
1361
1362           if (!incr_ctr) continue;
1363
1364           if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript.  */
1365             {
1366               gcc_assert(vecsub[d]);
1367
1368               if (!vecsub[d]->next)
1369                 vecsub[d] = ref->u.ar.start[d]->value.constructor;
1370               else
1371                 {
1372                   vecsub[d] = vecsub[d]->next;
1373                   incr_ctr = false;
1374                 }
1375               mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1376             }
1377           else
1378             {
1379               mpz_add (ctr[d], ctr[d], stride[d]);
1380
1381               if (mpz_cmp_ui (stride[d], 0) > 0
1382                   ? mpz_cmp (ctr[d], end[d]) > 0
1383                   : mpz_cmp (ctr[d], end[d]) < 0)
1384                 mpz_set (ctr[d], start[d]);
1385               else
1386                 incr_ctr = false;
1387             }
1388         }
1389
1390       /* There must be a better way of dealing with negative strides
1391          than resetting the index and the constructor pointer!  */
1392       if (mpz_cmp (ptr, index) < 0)
1393         {
1394           mpz_set_ui (index, 0);
1395           cons = base;
1396         }
1397
1398       while (cons && cons->next && mpz_cmp (ptr, index) > 0)
1399         {
1400           mpz_add_ui (index, index, one);
1401           cons = cons->next;
1402         }
1403
1404       gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
1405     }
1406
1407   mpz_clear (ptr);
1408   mpz_clear (index);
1409
1410 cleanup:
1411
1412   mpz_clear (delta_mpz);
1413   mpz_clear (tmp_mpz);
1414   mpz_clear (nelts);
1415   for (d = 0; d < rank; d++)
1416     {
1417       mpz_clear (delta[d]);
1418       mpz_clear (start[d]);
1419       mpz_clear (end[d]);
1420       mpz_clear (ctr[d]);
1421       mpz_clear (stride[d]);
1422     }
1423   gfc_free_constructor (base);
1424   return t;
1425 }
1426
1427 /* Pull a substring out of an expression.  */
1428
1429 static gfc_try
1430 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1431 {
1432   int end;
1433   int start;
1434   int length;
1435   gfc_char_t *chr;
1436
1437   if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1438       || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1439     return FAILURE;
1440
1441   *newp = gfc_copy_expr (p);
1442   gfc_free ((*newp)->value.character.string);
1443
1444   end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1445   start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1446   length = end - start + 1;
1447
1448   chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
1449   (*newp)->value.character.length = length;
1450   memcpy (chr, &p->value.character.string[start - 1],
1451           length * sizeof (gfc_char_t));
1452   chr[length] = '\0';
1453   return SUCCESS;
1454 }
1455
1456
1457
1458 /* Simplify a subobject reference of a constructor.  This occurs when
1459    parameter variable values are substituted.  */
1460
1461 static gfc_try
1462 simplify_const_ref (gfc_expr *p)
1463 {
1464   gfc_constructor *cons;
1465   gfc_expr *newp;
1466
1467   while (p->ref)
1468     {
1469       switch (p->ref->type)
1470         {
1471         case REF_ARRAY:
1472           switch (p->ref->u.ar.type)
1473             {
1474             case AR_ELEMENT:
1475               if (find_array_element (p->value.constructor, &p->ref->u.ar,
1476                                       &cons) == FAILURE)
1477                 return FAILURE;
1478
1479               if (!cons)
1480                 return SUCCESS;
1481
1482               remove_subobject_ref (p, cons);
1483               break;
1484
1485             case AR_SECTION:
1486               if (find_array_section (p, p->ref) == FAILURE)
1487                 return FAILURE;
1488               p->ref->u.ar.type = AR_FULL;
1489
1490             /* Fall through.  */
1491
1492             case AR_FULL:
1493               if (p->ref->next != NULL
1494                   && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1495                 {
1496                   cons = p->value.constructor;
1497                   for (; cons; cons = cons->next)
1498                     {
1499                       cons->expr->ref = gfc_copy_ref (p->ref->next);
1500                       if (simplify_const_ref (cons->expr) == FAILURE)
1501                         return FAILURE;
1502                     }
1503
1504                   /* If this is a CHARACTER array and we possibly took a
1505                      substring out of it, update the type-spec's character
1506                      length according to the first element (as all should have
1507                      the same length).  */
1508                   if (p->ts.type == BT_CHARACTER)
1509                     {
1510                       int string_len;
1511
1512                       gcc_assert (p->ref->next);
1513                       gcc_assert (!p->ref->next->next);
1514                       gcc_assert (p->ref->next->type == REF_SUBSTRING);
1515
1516                       if (p->value.constructor)
1517                         {
1518                           const gfc_expr* first = p->value.constructor->expr;
1519                           gcc_assert (first->expr_type == EXPR_CONSTANT);
1520                           gcc_assert (first->ts.type == BT_CHARACTER);
1521                           string_len = first->value.character.length;
1522                         }
1523                       else
1524                         string_len = 0;
1525
1526                       if (!p->ts.u.cl)
1527                         p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
1528                                                       NULL);
1529                       else
1530                         gfc_free_expr (p->ts.u.cl->length);
1531
1532                       p->ts.u.cl->length = gfc_int_expr (string_len);
1533                     }
1534                 }
1535               gfc_free_ref_list (p->ref);
1536               p->ref = NULL;
1537               break;
1538
1539             default:
1540               return SUCCESS;
1541             }
1542
1543           break;
1544
1545         case REF_COMPONENT:
1546           cons = find_component_ref (p->value.constructor, p->ref);
1547           remove_subobject_ref (p, cons);
1548           break;
1549
1550         case REF_SUBSTRING:
1551           if (find_substring_ref (p, &newp) == FAILURE)
1552             return FAILURE;
1553
1554           gfc_replace_expr (p, newp);
1555           gfc_free_ref_list (p->ref);
1556           p->ref = NULL;
1557           break;
1558         }
1559     }
1560
1561   return SUCCESS;
1562 }
1563
1564
1565 /* Simplify a chain of references.  */
1566
1567 static gfc_try
1568 simplify_ref_chain (gfc_ref *ref, int type)
1569 {
1570   int n;
1571
1572   for (; ref; ref = ref->next)
1573     {
1574       switch (ref->type)
1575         {
1576         case REF_ARRAY:
1577           for (n = 0; n < ref->u.ar.dimen; n++)
1578             {
1579               if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
1580                 return FAILURE;
1581               if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
1582                 return FAILURE;
1583               if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
1584                 return FAILURE;
1585             }
1586           break;
1587
1588         case REF_SUBSTRING:
1589           if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1590             return FAILURE;
1591           if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1592             return FAILURE;
1593           break;
1594
1595         default:
1596           break;
1597         }
1598     }
1599   return SUCCESS;
1600 }
1601
1602
1603 /* Try to substitute the value of a parameter variable.  */
1604
1605 static gfc_try
1606 simplify_parameter_variable (gfc_expr *p, int type)
1607 {
1608   gfc_expr *e;
1609   gfc_try t;
1610
1611   e = gfc_copy_expr (p->symtree->n.sym->value);
1612   if (e == NULL)
1613     return FAILURE;
1614
1615   e->rank = p->rank;
1616
1617   /* Do not copy subobject refs for constant.  */
1618   if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1619     e->ref = gfc_copy_ref (p->ref);
1620   t = gfc_simplify_expr (e, type);
1621
1622   /* Only use the simplification if it eliminated all subobject references.  */
1623   if (t == SUCCESS && !e->ref)
1624     gfc_replace_expr (p, e);
1625   else
1626     gfc_free_expr (e);
1627
1628   return t;
1629 }
1630
1631 /* Given an expression, simplify it by collapsing constant
1632    expressions.  Most simplification takes place when the expression
1633    tree is being constructed.  If an intrinsic function is simplified
1634    at some point, we get called again to collapse the result against
1635    other constants.
1636
1637    We work by recursively simplifying expression nodes, simplifying
1638    intrinsic functions where possible, which can lead to further
1639    constant collapsing.  If an operator has constant operand(s), we
1640    rip the expression apart, and rebuild it, hoping that it becomes
1641    something simpler.
1642
1643    The expression type is defined for:
1644      0   Basic expression parsing
1645      1   Simplifying array constructors -- will substitute
1646          iterator values.
1647    Returns FAILURE on error, SUCCESS otherwise.
1648    NOTE: Will return SUCCESS even if the expression can not be simplified.  */
1649
1650 gfc_try
1651 gfc_simplify_expr (gfc_expr *p, int type)
1652 {
1653   gfc_actual_arglist *ap;
1654
1655   if (p == NULL)
1656     return SUCCESS;
1657
1658   switch (p->expr_type)
1659     {
1660     case EXPR_CONSTANT:
1661     case EXPR_NULL:
1662       break;
1663
1664     case EXPR_FUNCTION:
1665       for (ap = p->value.function.actual; ap; ap = ap->next)
1666         if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1667           return FAILURE;
1668
1669       if (p->value.function.isym != NULL
1670           && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1671         return FAILURE;
1672
1673       break;
1674
1675     case EXPR_SUBSTRING:
1676       if (simplify_ref_chain (p->ref, type) == FAILURE)
1677         return FAILURE;
1678
1679       if (gfc_is_constant_expr (p))
1680         {
1681           gfc_char_t *s;
1682           int start, end;
1683
1684           start = 0;
1685           if (p->ref && p->ref->u.ss.start)
1686             {
1687               gfc_extract_int (p->ref->u.ss.start, &start);
1688               start--;  /* Convert from one-based to zero-based.  */
1689             }
1690
1691           end = p->value.character.length;
1692           if (p->ref && p->ref->u.ss.end)
1693             gfc_extract_int (p->ref->u.ss.end, &end);
1694
1695           s = gfc_get_wide_string (end - start + 2);
1696           memcpy (s, p->value.character.string + start,
1697                   (end - start) * sizeof (gfc_char_t));
1698           s[end - start + 1] = '\0';  /* TODO: C-style string.  */
1699           gfc_free (p->value.character.string);
1700           p->value.character.string = s;
1701           p->value.character.length = end - start;
1702           p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1703           p->ts.u.cl->length = gfc_int_expr (p->value.character.length);
1704           gfc_free_ref_list (p->ref);
1705           p->ref = NULL;
1706           p->expr_type = EXPR_CONSTANT;
1707         }
1708       break;
1709
1710     case EXPR_OP:
1711       if (simplify_intrinsic_op (p, type) == FAILURE)
1712         return FAILURE;
1713       break;
1714
1715     case EXPR_VARIABLE:
1716       /* Only substitute array parameter variables if we are in an
1717          initialization expression, or we want a subsection.  */
1718       if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1719           && (gfc_init_expr || p->ref
1720               || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1721         {
1722           if (simplify_parameter_variable (p, type) == FAILURE)
1723             return FAILURE;
1724           break;
1725         }
1726
1727       if (type == 1)
1728         {
1729           gfc_simplify_iterator_var (p);
1730         }
1731
1732       /* Simplify subcomponent references.  */
1733       if (simplify_ref_chain (p->ref, type) == FAILURE)
1734         return FAILURE;
1735
1736       break;
1737
1738     case EXPR_STRUCTURE:
1739     case EXPR_ARRAY:
1740       if (simplify_ref_chain (p->ref, type) == FAILURE)
1741         return FAILURE;
1742
1743       if (simplify_constructor (p->value.constructor, type) == FAILURE)
1744         return FAILURE;
1745
1746       if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
1747           && p->ref->u.ar.type == AR_FULL)
1748           gfc_expand_constructor (p);
1749
1750       if (simplify_const_ref (p) == FAILURE)
1751         return FAILURE;
1752
1753       break;
1754
1755     case EXPR_COMPCALL:
1756     case EXPR_PPC:
1757       gcc_unreachable ();
1758       break;
1759     }
1760
1761   return SUCCESS;
1762 }
1763
1764
1765 /* Returns the type of an expression with the exception that iterator
1766    variables are automatically integers no matter what else they may
1767    be declared as.  */
1768
1769 static bt
1770 et0 (gfc_expr *e)
1771 {
1772   if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1773     return BT_INTEGER;
1774
1775   return e->ts.type;
1776 }
1777
1778
1779 /* Check an intrinsic arithmetic operation to see if it is consistent
1780    with some type of expression.  */
1781
1782 static gfc_try check_init_expr (gfc_expr *);
1783
1784
1785 /* Scalarize an expression for an elemental intrinsic call.  */
1786
1787 static gfc_try
1788 scalarize_intrinsic_call (gfc_expr *e)
1789 {
1790   gfc_actual_arglist *a, *b;
1791   gfc_constructor *args[5], *ctor, *new_ctor;
1792   gfc_expr *expr, *old;
1793   int n, i, rank[5], array_arg;
1794
1795   /* Find which, if any, arguments are arrays.  Assume that the old
1796      expression carries the type information and that the first arg
1797      that is an array expression carries all the shape information.*/
1798   n = array_arg = 0;
1799   a = e->value.function.actual;
1800   for (; a; a = a->next)
1801     {
1802       n++;
1803       if (a->expr->expr_type != EXPR_ARRAY)
1804         continue;
1805       array_arg = n;
1806       expr = gfc_copy_expr (a->expr);
1807       break;
1808     }
1809
1810   if (!array_arg)
1811     return FAILURE;
1812
1813   old = gfc_copy_expr (e);
1814
1815   gfc_free_constructor (expr->value.constructor);
1816   expr->value.constructor = NULL;
1817
1818   expr->ts = old->ts;
1819   expr->where = old->where;
1820   expr->expr_type = EXPR_ARRAY;
1821
1822   /* Copy the array argument constructors into an array, with nulls
1823      for the scalars.  */
1824   n = 0;
1825   a = old->value.function.actual;
1826   for (; a; a = a->next)
1827     {
1828       /* Check that this is OK for an initialization expression.  */
1829       if (a->expr && check_init_expr (a->expr) == FAILURE)
1830         goto cleanup;
1831
1832       rank[n] = 0;
1833       if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
1834         {
1835           rank[n] = a->expr->rank;
1836           ctor = a->expr->symtree->n.sym->value->value.constructor;
1837           args[n] = gfc_copy_constructor (ctor);
1838         }
1839       else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
1840         {
1841           if (a->expr->rank)
1842             rank[n] = a->expr->rank;
1843           else
1844             rank[n] = 1;
1845           args[n] = gfc_copy_constructor (a->expr->value.constructor);
1846         }
1847       else
1848         args[n] = NULL;
1849       n++;
1850     }
1851
1852
1853   /* Using the array argument as the master, step through the array
1854      calling the function for each element and advancing the array
1855      constructors together.  */
1856   ctor = args[array_arg - 1];
1857   new_ctor = NULL;
1858   for (; ctor; ctor = ctor->next)
1859     {
1860           if (expr->value.constructor == NULL)
1861             expr->value.constructor
1862                 = new_ctor = gfc_get_constructor ();
1863           else
1864             {
1865               new_ctor->next = gfc_get_constructor ();
1866               new_ctor = new_ctor->next;
1867             }
1868           new_ctor->expr = gfc_copy_expr (old);
1869           gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
1870           a = NULL;
1871           b = old->value.function.actual;
1872           for (i = 0; i < n; i++)
1873             {
1874               if (a == NULL)
1875                 new_ctor->expr->value.function.actual
1876                         = a = gfc_get_actual_arglist ();
1877               else
1878                 {
1879                   a->next = gfc_get_actual_arglist ();
1880                   a = a->next;
1881                 }
1882               if (args[i])
1883                 a->expr = gfc_copy_expr (args[i]->expr);
1884               else
1885                 a->expr = gfc_copy_expr (b->expr);
1886
1887               b = b->next;
1888             }
1889
1890           /* Simplify the function calls.  If the simplification fails, the
1891              error will be flagged up down-stream or the library will deal
1892              with it.  */
1893           gfc_simplify_expr (new_ctor->expr, 0);
1894
1895           for (i = 0; i < n; i++)
1896             if (args[i])
1897               args[i] = args[i]->next;
1898
1899           for (i = 1; i < n; i++)
1900             if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
1901                          || (args[i] == NULL && args[array_arg - 1] != NULL)))
1902               goto compliance;
1903     }
1904
1905   free_expr0 (e);
1906   *e = *expr;
1907   gfc_free_expr (old);
1908   return SUCCESS;
1909
1910 compliance:
1911   gfc_error_now ("elemental function arguments at %C are not compliant");
1912
1913 cleanup:
1914   gfc_free_expr (expr);
1915   gfc_free_expr (old);
1916   return FAILURE;
1917 }
1918
1919
1920 static gfc_try
1921 check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
1922 {
1923   gfc_expr *op1 = e->value.op.op1;
1924   gfc_expr *op2 = e->value.op.op2;
1925
1926   if ((*check_function) (op1) == FAILURE)
1927     return FAILURE;
1928
1929   switch (e->value.op.op)
1930     {
1931     case INTRINSIC_UPLUS:
1932     case INTRINSIC_UMINUS:
1933       if (!numeric_type (et0 (op1)))
1934         goto not_numeric;
1935       break;
1936
1937     case INTRINSIC_EQ:
1938     case INTRINSIC_EQ_OS:
1939     case INTRINSIC_NE:
1940     case INTRINSIC_NE_OS:
1941     case INTRINSIC_GT:
1942     case INTRINSIC_GT_OS:
1943     case INTRINSIC_GE:
1944     case INTRINSIC_GE_OS:
1945     case INTRINSIC_LT:
1946     case INTRINSIC_LT_OS:
1947     case INTRINSIC_LE:
1948     case INTRINSIC_LE_OS:
1949       if ((*check_function) (op2) == FAILURE)
1950         return FAILURE;
1951
1952       if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
1953           && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
1954         {
1955           gfc_error ("Numeric or CHARACTER operands are required in "
1956                      "expression at %L", &e->where);
1957          return FAILURE;
1958         }
1959       break;
1960
1961     case INTRINSIC_PLUS:
1962     case INTRINSIC_MINUS:
1963     case INTRINSIC_TIMES:
1964     case INTRINSIC_DIVIDE:
1965     case INTRINSIC_POWER:
1966       if ((*check_function) (op2) == FAILURE)
1967         return FAILURE;
1968
1969       if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
1970         goto not_numeric;
1971
1972       break;
1973
1974     case INTRINSIC_CONCAT:
1975       if ((*check_function) (op2) == FAILURE)
1976         return FAILURE;
1977
1978       if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
1979         {
1980           gfc_error ("Concatenation operator in expression at %L "
1981                      "must have two CHARACTER operands", &op1->where);
1982           return FAILURE;
1983         }
1984
1985       if (op1->ts.kind != op2->ts.kind)
1986         {
1987           gfc_error ("Concat operator at %L must concatenate strings of the "
1988                      "same kind", &e->where);
1989           return FAILURE;
1990         }
1991
1992       break;
1993
1994     case INTRINSIC_NOT:
1995       if (et0 (op1) != BT_LOGICAL)
1996         {
1997           gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1998                      "operand", &op1->where);
1999           return FAILURE;
2000         }
2001
2002       break;
2003
2004     case INTRINSIC_AND:
2005     case INTRINSIC_OR:
2006     case INTRINSIC_EQV:
2007     case INTRINSIC_NEQV:
2008       if ((*check_function) (op2) == FAILURE)
2009         return FAILURE;
2010
2011       if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
2012         {
2013           gfc_error ("LOGICAL operands are required in expression at %L",
2014                      &e->where);
2015           return FAILURE;
2016         }
2017
2018       break;
2019
2020     case INTRINSIC_PARENTHESES:
2021       break;
2022
2023     default:
2024       gfc_error ("Only intrinsic operators can be used in expression at %L",
2025                  &e->where);
2026       return FAILURE;
2027     }
2028
2029   return SUCCESS;
2030
2031 not_numeric:
2032   gfc_error ("Numeric operands are required in expression at %L", &e->where);
2033
2034   return FAILURE;
2035 }
2036
2037
2038 static match
2039 check_init_expr_arguments (gfc_expr *e)
2040 {
2041   gfc_actual_arglist *ap;
2042
2043   for (ap = e->value.function.actual; ap; ap = ap->next)
2044     if (check_init_expr (ap->expr) == FAILURE)
2045       return MATCH_ERROR;
2046
2047   return MATCH_YES;
2048 }
2049
2050 static gfc_try check_restricted (gfc_expr *);
2051
2052 /* F95, 7.1.6.1, Initialization expressions, (7)
2053    F2003, 7.1.7 Initialization expression, (8)  */
2054
2055 static match
2056 check_inquiry (gfc_expr *e, int not_restricted)
2057 {
2058   const char *name;
2059   const char *const *functions;
2060
2061   static const char *const inquiry_func_f95[] = {
2062     "lbound", "shape", "size", "ubound",
2063     "bit_size", "len", "kind",
2064     "digits", "epsilon", "huge", "maxexponent", "minexponent",
2065     "precision", "radix", "range", "tiny",
2066     NULL
2067   };
2068
2069   static const char *const inquiry_func_f2003[] = {
2070     "lbound", "shape", "size", "ubound",
2071     "bit_size", "len", "kind",
2072     "digits", "epsilon", "huge", "maxexponent", "minexponent",
2073     "precision", "radix", "range", "tiny",
2074     "new_line", NULL
2075   };
2076
2077   int i;
2078   gfc_actual_arglist *ap;
2079
2080   if (!e->value.function.isym
2081       || !e->value.function.isym->inquiry)
2082     return MATCH_NO;
2083
2084   /* An undeclared parameter will get us here (PR25018).  */
2085   if (e->symtree == NULL)
2086     return MATCH_NO;
2087
2088   name = e->symtree->n.sym->name;
2089
2090   functions = (gfc_option.warn_std & GFC_STD_F2003)
2091                 ? inquiry_func_f2003 : inquiry_func_f95;
2092
2093   for (i = 0; functions[i]; i++)
2094     if (strcmp (functions[i], name) == 0)
2095       break;
2096
2097   if (functions[i] == NULL)
2098     return MATCH_ERROR;
2099
2100   /* At this point we have an inquiry function with a variable argument.  The
2101      type of the variable might be undefined, but we need it now, because the
2102      arguments of these functions are not allowed to be undefined.  */
2103
2104   for (ap = e->value.function.actual; ap; ap = ap->next)
2105     {
2106       if (!ap->expr)
2107         continue;
2108
2109       if (ap->expr->ts.type == BT_UNKNOWN)
2110         {
2111           if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2112               && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)
2113               == FAILURE)
2114             return MATCH_NO;
2115
2116           ap->expr->ts = ap->expr->symtree->n.sym->ts;
2117         }
2118
2119         /* Assumed character length will not reduce to a constant expression
2120            with LEN, as required by the standard.  */
2121         if (i == 5 && not_restricted
2122             && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2123             && ap->expr->symtree->n.sym->ts.u.cl->length == NULL)
2124           {
2125             gfc_error ("Assumed character length variable '%s' in constant "
2126                        "expression at %L", e->symtree->n.sym->name, &e->where);
2127               return MATCH_ERROR;
2128           }
2129         else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
2130           return MATCH_ERROR;
2131
2132         if (not_restricted == 0
2133               && ap->expr->expr_type != EXPR_VARIABLE
2134               && check_restricted (ap->expr) == FAILURE)
2135           return MATCH_ERROR;
2136     }
2137
2138   return MATCH_YES;
2139 }
2140
2141
2142 /* F95, 7.1.6.1, Initialization expressions, (5)
2143    F2003, 7.1.7 Initialization expression, (5)  */
2144
2145 static match
2146 check_transformational (gfc_expr *e)
2147 {
2148   static const char * const trans_func_f95[] = {
2149     "repeat", "reshape", "selected_int_kind",
2150     "selected_real_kind", "transfer", "trim", NULL
2151   };
2152
2153   static const char * const trans_func_f2003[] =  {
2154     "all", "any", "count", "dot_product", "matmul", "null", "pack",
2155     "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2156     "selected_real_kind", "spread", "sum", "transfer", "transpose",
2157     "trim", "unpack", NULL
2158   };
2159
2160   int i;
2161   const char *name;
2162   const char *const *functions;
2163
2164   if (!e->value.function.isym
2165       || !e->value.function.isym->transformational)
2166     return MATCH_NO;
2167
2168   name = e->symtree->n.sym->name;
2169
2170   functions = (gfc_option.allow_std & GFC_STD_F2003)
2171                 ? trans_func_f2003 : trans_func_f95;
2172
2173   /* NULL() is dealt with below.  */
2174   if (strcmp ("null", name) == 0)
2175     return MATCH_NO;
2176
2177   for (i = 0; functions[i]; i++)
2178     if (strcmp (functions[i], name) == 0)
2179        break;
2180
2181   if (functions[i] == NULL)
2182     {
2183       gfc_error("transformational intrinsic '%s' at %L is not permitted "
2184                 "in an initialization expression", name, &e->where);
2185       return MATCH_ERROR;
2186     }
2187
2188   return check_init_expr_arguments (e);
2189 }
2190
2191
2192 /* F95, 7.1.6.1, Initialization expressions, (6)
2193    F2003, 7.1.7 Initialization expression, (6)  */
2194
2195 static match
2196 check_null (gfc_expr *e)
2197 {
2198   if (strcmp ("null", e->symtree->n.sym->name) != 0)
2199     return MATCH_NO;
2200
2201   return check_init_expr_arguments (e);
2202 }
2203
2204
2205 static match
2206 check_elemental (gfc_expr *e)
2207 {
2208   if (!e->value.function.isym
2209       || !e->value.function.isym->elemental)
2210     return MATCH_NO;
2211
2212   if (e->ts.type != BT_INTEGER
2213       && e->ts.type != BT_CHARACTER
2214       && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
2215                         "nonstandard initialization expression at %L",
2216                         &e->where) == FAILURE)
2217     return MATCH_ERROR;
2218
2219   return check_init_expr_arguments (e);
2220 }
2221
2222
2223 static match
2224 check_conversion (gfc_expr *e)
2225 {
2226   if (!e->value.function.isym
2227       || !e->value.function.isym->conversion)
2228     return MATCH_NO;
2229
2230   return check_init_expr_arguments (e);
2231 }
2232
2233
2234 /* Verify that an expression is an initialization expression.  A side
2235    effect is that the expression tree is reduced to a single constant
2236    node if all goes well.  This would normally happen when the
2237    expression is constructed but function references are assumed to be
2238    intrinsics in the context of initialization expressions.  If
2239    FAILURE is returned an error message has been generated.  */
2240
2241 static gfc_try
2242 check_init_expr (gfc_expr *e)
2243 {
2244   match m;
2245   gfc_try t;
2246
2247   if (e == NULL)
2248     return SUCCESS;
2249
2250   switch (e->expr_type)
2251     {
2252     case EXPR_OP:
2253       t = check_intrinsic_op (e, check_init_expr);
2254       if (t == SUCCESS)
2255         t = gfc_simplify_expr (e, 0);
2256
2257       break;
2258
2259     case EXPR_FUNCTION:
2260       t = FAILURE;
2261
2262       if ((m = check_specification_function (e)) != MATCH_YES)
2263         {
2264           gfc_intrinsic_sym* isym;
2265           gfc_symbol* sym;
2266
2267           sym = e->symtree->n.sym;
2268           if (!gfc_is_intrinsic (sym, 0, e->where)
2269               || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
2270             {
2271               gfc_error ("Function '%s' in initialization expression at %L "
2272                          "must be an intrinsic or a specification function",
2273                          e->symtree->n.sym->name, &e->where);
2274               break;
2275             }
2276
2277           if ((m = check_conversion (e)) == MATCH_NO
2278               && (m = check_inquiry (e, 1)) == MATCH_NO
2279               && (m = check_null (e)) == MATCH_NO
2280               && (m = check_transformational (e)) == MATCH_NO
2281               && (m = check_elemental (e)) == MATCH_NO)
2282             {
2283               gfc_error ("Intrinsic function '%s' at %L is not permitted "
2284                          "in an initialization expression",
2285                          e->symtree->n.sym->name, &e->where);
2286               m = MATCH_ERROR;
2287             }
2288
2289           /* Try to scalarize an elemental intrinsic function that has an
2290              array argument.  */
2291           isym = gfc_find_function (e->symtree->n.sym->name);
2292           if (isym && isym->elemental
2293                 && (t = scalarize_intrinsic_call (e)) == SUCCESS)
2294             break;
2295         }
2296
2297       if (m == MATCH_YES)
2298         t = gfc_simplify_expr (e, 0);
2299
2300       break;
2301
2302     case EXPR_VARIABLE:
2303       t = SUCCESS;
2304
2305       if (gfc_check_iter_variable (e) == SUCCESS)
2306         break;
2307
2308       if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2309         {
2310           /* A PARAMETER shall not be used to define itself, i.e.
2311                 REAL, PARAMETER :: x = transfer(0, x)
2312              is invalid.  */
2313           if (!e->symtree->n.sym->value)
2314             {
2315               gfc_error("PARAMETER '%s' is used at %L before its definition "
2316                         "is complete", e->symtree->n.sym->name, &e->where);
2317               t = FAILURE;
2318             }
2319           else
2320             t = simplify_parameter_variable (e, 0);
2321
2322           break;
2323         }
2324
2325       if (gfc_in_match_data ())
2326         break;
2327
2328       t = FAILURE;
2329
2330       if (e->symtree->n.sym->as)
2331         {
2332           switch (e->symtree->n.sym->as->type)
2333             {
2334               case AS_ASSUMED_SIZE:
2335                 gfc_error ("Assumed size array '%s' at %L is not permitted "
2336                            "in an initialization expression",
2337                            e->symtree->n.sym->name, &e->where);
2338                 break;
2339
2340               case AS_ASSUMED_SHAPE:
2341                 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2342                            "in an initialization expression",
2343                            e->symtree->n.sym->name, &e->where);
2344                 break;
2345
2346               case AS_DEFERRED:
2347                 gfc_error ("Deferred array '%s' at %L is not permitted "
2348                            "in an initialization expression",
2349                            e->symtree->n.sym->name, &e->where);
2350                 break;
2351
2352               case AS_EXPLICIT:
2353                 gfc_error ("Array '%s' at %L is a variable, which does "
2354                            "not reduce to a constant expression",
2355                            e->symtree->n.sym->name, &e->where);
2356                 break;
2357
2358               default:
2359                 gcc_unreachable();
2360           }
2361         }
2362       else
2363         gfc_error ("Parameter '%s' at %L has not been declared or is "
2364                    "a variable, which does not reduce to a constant "
2365                    "expression", e->symtree->n.sym->name, &e->where);
2366
2367       break;
2368
2369     case EXPR_CONSTANT:
2370     case EXPR_NULL:
2371       t = SUCCESS;
2372       break;
2373
2374     case EXPR_SUBSTRING:
2375       t = check_init_expr (e->ref->u.ss.start);
2376       if (t == FAILURE)
2377         break;
2378
2379       t = check_init_expr (e->ref->u.ss.end);
2380       if (t == SUCCESS)
2381         t = gfc_simplify_expr (e, 0);
2382
2383       break;
2384
2385     case EXPR_STRUCTURE:
2386       if (e->ts.is_iso_c)
2387         t = SUCCESS;
2388       else
2389         t = gfc_check_constructor (e, check_init_expr);
2390       break;
2391
2392     case EXPR_ARRAY:
2393       t = gfc_check_constructor (e, check_init_expr);
2394       if (t == FAILURE)
2395         break;
2396
2397       t = gfc_expand_constructor (e);
2398       if (t == FAILURE)
2399         break;
2400
2401       t = gfc_check_constructor_type (e);
2402       break;
2403
2404     default:
2405       gfc_internal_error ("check_init_expr(): Unknown expression type");
2406     }
2407
2408   return t;
2409 }
2410
2411 /* Reduces a general expression to an initialization expression (a constant).
2412    This used to be part of gfc_match_init_expr.
2413    Note that this function doesn't free the given expression on FAILURE.  */
2414
2415 gfc_try
2416 gfc_reduce_init_expr (gfc_expr *expr)
2417 {
2418   gfc_try t;
2419
2420   gfc_init_expr = 1;
2421   t = gfc_resolve_expr (expr);
2422   if (t == SUCCESS)
2423     t = check_init_expr (expr);
2424   gfc_init_expr = 0;
2425
2426   if (t == FAILURE)
2427     return FAILURE;
2428
2429   if (expr->expr_type == EXPR_ARRAY
2430       && (gfc_check_constructor_type (expr) == FAILURE
2431       || gfc_expand_constructor (expr) == FAILURE))
2432     return FAILURE;
2433
2434   /* Not all inquiry functions are simplified to constant expressions
2435      so it is necessary to call check_inquiry again.  */
2436   if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) != MATCH_YES
2437       && !gfc_in_match_data ())
2438     {
2439       gfc_error ("Initialization expression didn't reduce %C");
2440       return FAILURE;
2441     }
2442
2443   return SUCCESS;
2444 }
2445
2446
2447 /* Match an initialization expression.  We work by first matching an
2448    expression, then reducing it to a constant.  The reducing it to
2449    constant part requires a global variable to flag the prohibition
2450    of a non-integer exponent in -std=f95 mode.  */
2451
2452 bool init_flag = false;
2453
2454 match
2455 gfc_match_init_expr (gfc_expr **result)
2456 {
2457   gfc_expr *expr;
2458   match m;
2459   gfc_try t;
2460
2461   expr = NULL;
2462
2463   init_flag = true;
2464
2465   m = gfc_match_expr (&expr);
2466   if (m != MATCH_YES)
2467     {
2468       init_flag = false;
2469       return m;
2470     }
2471
2472   t = gfc_reduce_init_expr (expr);
2473   if (t != SUCCESS)
2474     {
2475       gfc_free_expr (expr);
2476       init_flag = false;
2477       return MATCH_ERROR;
2478     }
2479
2480   *result = expr;
2481   init_flag = false;
2482
2483   return MATCH_YES;
2484 }
2485
2486
2487 /* Given an actual argument list, test to see that each argument is a
2488    restricted expression and optionally if the expression type is
2489    integer or character.  */
2490
2491 static gfc_try
2492 restricted_args (gfc_actual_arglist *a)
2493 {
2494   for (; a; a = a->next)
2495     {
2496       if (check_restricted (a->expr) == FAILURE)
2497         return FAILURE;
2498     }
2499
2500   return SUCCESS;
2501 }
2502
2503
2504 /************* Restricted/specification expressions *************/
2505
2506
2507 /* Make sure a non-intrinsic function is a specification function.  */
2508
2509 static gfc_try
2510 external_spec_function (gfc_expr *e)
2511 {
2512   gfc_symbol *f;
2513
2514   f = e->value.function.esym;
2515
2516   if (f->attr.proc == PROC_ST_FUNCTION)
2517     {
2518       gfc_error ("Specification function '%s' at %L cannot be a statement "
2519                  "function", f->name, &e->where);
2520       return FAILURE;
2521     }
2522
2523   if (f->attr.proc == PROC_INTERNAL)
2524     {
2525       gfc_error ("Specification function '%s' at %L cannot be an internal "
2526                  "function", f->name, &e->where);
2527       return FAILURE;
2528     }
2529
2530   if (!f->attr.pure && !f->attr.elemental)
2531     {
2532       gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2533                  &e->where);
2534       return FAILURE;
2535     }
2536
2537   if (f->attr.recursive)
2538     {
2539       gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2540                  f->name, &e->where);
2541       return FAILURE;
2542     }
2543
2544   return restricted_args (e->value.function.actual);
2545 }
2546
2547
2548 /* Check to see that a function reference to an intrinsic is a
2549    restricted expression.  */
2550
2551 static gfc_try
2552 restricted_intrinsic (gfc_expr *e)
2553 {
2554   /* TODO: Check constraints on inquiry functions.  7.1.6.2 (7).  */
2555   if (check_inquiry (e, 0) == MATCH_YES)
2556     return SUCCESS;
2557
2558   return restricted_args (e->value.function.actual);
2559 }
2560
2561
2562 /* Check the expressions of an actual arglist.  Used by check_restricted.  */
2563
2564 static gfc_try
2565 check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
2566 {
2567   for (; arg; arg = arg->next)
2568     if (checker (arg->expr) == FAILURE)
2569       return FAILURE;
2570
2571   return SUCCESS;
2572 }
2573
2574
2575 /* Check the subscription expressions of a reference chain with a checking
2576    function; used by check_restricted.  */
2577
2578 static gfc_try
2579 check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
2580 {
2581   int dim;
2582
2583   if (!ref)
2584     return SUCCESS;
2585
2586   switch (ref->type)
2587     {
2588     case REF_ARRAY:
2589       for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2590         {
2591           if (checker (ref->u.ar.start[dim]) == FAILURE)
2592             return FAILURE;
2593           if (checker (ref->u.ar.end[dim]) == FAILURE)
2594             return FAILURE;
2595           if (checker (ref->u.ar.stride[dim]) == FAILURE)
2596             return FAILURE;
2597         }
2598       break;
2599
2600     case REF_COMPONENT:
2601       /* Nothing needed, just proceed to next reference.  */
2602       break;
2603
2604     case REF_SUBSTRING:
2605       if (checker (ref->u.ss.start) == FAILURE)
2606         return FAILURE;
2607       if (checker (ref->u.ss.end) == FAILURE)
2608         return FAILURE;
2609       break;
2610
2611     default:
2612       gcc_unreachable ();
2613       break;
2614     }
2615
2616   return check_references (ref->next, checker);
2617 }
2618
2619
2620 /* Verify that an expression is a restricted expression.  Like its
2621    cousin check_init_expr(), an error message is generated if we
2622    return FAILURE.  */
2623
2624 static gfc_try
2625 check_restricted (gfc_expr *e)
2626 {
2627   gfc_symbol* sym;
2628   gfc_try t;
2629
2630   if (e == NULL)
2631     return SUCCESS;
2632
2633   switch (e->expr_type)
2634     {
2635     case EXPR_OP:
2636       t = check_intrinsic_op (e, check_restricted);
2637       if (t == SUCCESS)
2638         t = gfc_simplify_expr (e, 0);
2639
2640       break;
2641
2642     case EXPR_FUNCTION:
2643       if (e->value.function.esym)
2644         {
2645           t = check_arglist (e->value.function.actual, &check_restricted);
2646           if (t == SUCCESS)
2647             t = external_spec_function (e);
2648         }
2649       else
2650         {
2651           if (e->value.function.isym && e->value.function.isym->inquiry)
2652             t = SUCCESS;
2653           else
2654             t = check_arglist (e->value.function.actual, &check_restricted);
2655
2656           if (t == SUCCESS)
2657             t = restricted_intrinsic (e);
2658         }
2659       break;
2660
2661     case EXPR_VARIABLE:
2662       sym = e->symtree->n.sym;
2663       t = FAILURE;
2664
2665       /* If a dummy argument appears in a context that is valid for a
2666          restricted expression in an elemental procedure, it will have
2667          already been simplified away once we get here.  Therefore we
2668          don't need to jump through hoops to distinguish valid from
2669          invalid cases.  */
2670       if (sym->attr.dummy && sym->ns == gfc_current_ns
2671           && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
2672         {
2673           gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2674                      sym->name, &e->where);
2675           break;
2676         }
2677
2678       if (sym->attr.optional)
2679         {
2680           gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2681                      sym->name, &e->where);
2682           break;
2683         }
2684
2685       if (sym->attr.intent == INTENT_OUT)
2686         {
2687           gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2688                      sym->name, &e->where);
2689           break;
2690         }
2691
2692       /* Check reference chain if any.  */
2693       if (check_references (e->ref, &check_restricted) == FAILURE)
2694         break;
2695
2696       /* gfc_is_formal_arg broadcasts that a formal argument list is being
2697          processed in resolve.c(resolve_formal_arglist).  This is done so
2698          that host associated dummy array indices are accepted (PR23446).
2699          This mechanism also does the same for the specification expressions
2700          of array-valued functions.  */
2701       if (e->error
2702             || sym->attr.in_common
2703             || sym->attr.use_assoc
2704             || sym->attr.dummy
2705             || sym->attr.implied_index
2706             || sym->attr.flavor == FL_PARAMETER
2707             || (sym->ns && sym->ns == gfc_current_ns->parent)
2708             || (sym->ns && gfc_current_ns->parent
2709                   && sym->ns == gfc_current_ns->parent->parent)
2710             || (sym->ns->proc_name != NULL
2711                   && sym->ns->proc_name->attr.flavor == FL_MODULE)
2712             || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2713         {
2714           t = SUCCESS;
2715           break;
2716         }
2717
2718       gfc_error ("Variable '%s' cannot appear in the expression at %L",
2719                  sym->name, &e->where);
2720       /* Prevent a repetition of the error.  */
2721       e->error = 1;
2722       break;
2723
2724     case EXPR_NULL:
2725     case EXPR_CONSTANT:
2726       t = SUCCESS;
2727       break;
2728
2729     case EXPR_SUBSTRING:
2730       t = gfc_specification_expr (e->ref->u.ss.start);
2731       if (t == FAILURE)
2732         break;
2733
2734       t = gfc_specification_expr (e->ref->u.ss.end);
2735       if (t == SUCCESS)
2736         t = gfc_simplify_expr (e, 0);
2737
2738       break;
2739
2740     case EXPR_STRUCTURE:
2741       t = gfc_check_constructor (e, check_restricted);
2742       break;
2743
2744     case EXPR_ARRAY:
2745       t = gfc_check_constructor (e, check_restricted);
2746       break;
2747
2748     default:
2749       gfc_internal_error ("check_restricted(): Unknown expression type");
2750     }
2751
2752   return t;
2753 }
2754
2755
2756 /* Check to see that an expression is a specification expression.  If
2757    we return FAILURE, an error has been generated.  */
2758
2759 gfc_try
2760 gfc_specification_expr (gfc_expr *e)
2761 {
2762
2763   if (e == NULL)
2764     return SUCCESS;
2765
2766   if (e->ts.type != BT_INTEGER)
2767     {
2768       gfc_error ("Expression at %L must be of INTEGER type, found %s",
2769                  &e->where, gfc_basic_typename (e->ts.type));
2770       return FAILURE;
2771     }
2772
2773   if (e->expr_type == EXPR_FUNCTION
2774           && !e->value.function.isym
2775           && !e->value.function.esym
2776           && !gfc_pure (e->symtree->n.sym))
2777     {
2778       gfc_error ("Function '%s' at %L must be PURE",
2779                  e->symtree->n.sym->name, &e->where);
2780       /* Prevent repeat error messages.  */
2781       e->symtree->n.sym->attr.pure = 1;
2782       return FAILURE;
2783     }
2784
2785   if (e->rank != 0)
2786     {
2787       gfc_error ("Expression at %L must be scalar", &e->where);
2788       return FAILURE;
2789     }
2790
2791   if (gfc_simplify_expr (e, 0) == FAILURE)
2792     return FAILURE;
2793
2794   return check_restricted (e);
2795 }
2796
2797
2798 /************** Expression conformance checks.  *************/
2799
2800 /* Given two expressions, make sure that the arrays are conformable.  */
2801
2802 gfc_try
2803 gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
2804 {
2805   int op1_flag, op2_flag, d;
2806   mpz_t op1_size, op2_size;
2807   gfc_try t;
2808
2809   va_list argp;
2810   char buffer[240];
2811
2812   if (op1->rank == 0 || op2->rank == 0)
2813     return SUCCESS;
2814
2815   va_start (argp, optype_msgid);
2816   vsnprintf (buffer, 240, optype_msgid, argp);
2817   va_end (argp);
2818
2819   if (op1->rank != op2->rank)
2820     {
2821       gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
2822                  op1->rank, op2->rank, &op1->where);
2823       return FAILURE;
2824     }
2825
2826   t = SUCCESS;
2827
2828   for (d = 0; d < op1->rank; d++)
2829     {
2830       op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
2831       op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
2832
2833       if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
2834         {
2835           gfc_error ("Different shape for %s at %L on dimension %d "
2836                      "(%d and %d)", _(buffer), &op1->where, d + 1,
2837                      (int) mpz_get_si (op1_size),
2838                      (int) mpz_get_si (op2_size));
2839
2840           t = FAILURE;
2841         }
2842
2843       if (op1_flag)
2844         mpz_clear (op1_size);
2845       if (op2_flag)
2846         mpz_clear (op2_size);
2847
2848       if (t == FAILURE)
2849         return FAILURE;
2850     }
2851
2852   return SUCCESS;
2853 }
2854
2855
2856 /* Given an assignable expression and an arbitrary expression, make
2857    sure that the assignment can take place.  */
2858
2859 gfc_try
2860 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
2861 {
2862   gfc_symbol *sym;
2863   gfc_ref *ref;
2864   int has_pointer;
2865
2866   sym = lvalue->symtree->n.sym;
2867
2868   /* Check INTENT(IN), unless the object itself is the component or
2869      sub-component of a pointer.  */
2870   has_pointer = sym->attr.pointer;
2871
2872   for (ref = lvalue->ref; ref; ref = ref->next)
2873     if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
2874       {
2875         has_pointer = 1;
2876         break;
2877       }
2878
2879   if (!has_pointer && sym->attr.intent == INTENT_IN)
2880     {
2881       gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2882                  sym->name, &lvalue->where);
2883       return FAILURE;
2884     }
2885
2886   /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2887      variable local to a function subprogram.  Its existence begins when
2888      execution of the function is initiated and ends when execution of the
2889      function is terminated...
2890      Therefore, the left hand side is no longer a variable, when it is:  */
2891   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
2892       && !sym->attr.external)
2893     {
2894       bool bad_proc;
2895       bad_proc = false;
2896
2897       /* (i) Use associated;  */
2898       if (sym->attr.use_assoc)
2899         bad_proc = true;
2900
2901       /* (ii) The assignment is in the main program; or  */
2902       if (gfc_current_ns->proc_name->attr.is_main_program)
2903         bad_proc = true;
2904
2905       /* (iii) A module or internal procedure...  */
2906       if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
2907            || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
2908           && gfc_current_ns->parent
2909           && (!(gfc_current_ns->parent->proc_name->attr.function
2910                 || gfc_current_ns->parent->proc_name->attr.subroutine)
2911               || gfc_current_ns->parent->proc_name->attr.is_main_program))
2912         {
2913           /* ... that is not a function...  */
2914           if (!gfc_current_ns->proc_name->attr.function)
2915             bad_proc = true;
2916
2917           /* ... or is not an entry and has a different name.  */
2918           if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
2919             bad_proc = true;
2920         }
2921
2922       /* (iv) Host associated and not the function symbol or the
2923               parent result.  This picks up sibling references, which
2924               cannot be entries.  */
2925       if (!sym->attr.entry
2926             && sym->ns == gfc_current_ns->parent
2927             && sym != gfc_current_ns->proc_name
2928             && sym != gfc_current_ns->parent->proc_name->result)
2929         bad_proc = true;
2930
2931       if (bad_proc)
2932         {
2933           gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
2934           return FAILURE;
2935         }
2936     }
2937
2938   if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
2939     {
2940       gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2941                  lvalue->rank, rvalue->rank, &lvalue->where);
2942       return FAILURE;
2943     }
2944
2945   if (lvalue->ts.type == BT_UNKNOWN)
2946     {
2947       gfc_error ("Variable type is UNKNOWN in assignment at %L",
2948                  &lvalue->where);
2949       return FAILURE;
2950     }
2951
2952   if (rvalue->expr_type == EXPR_NULL)
2953     {
2954       if (has_pointer && (ref == NULL || ref->next == NULL)
2955           && lvalue->symtree->n.sym->attr.data)
2956         return SUCCESS;
2957       else
2958         {
2959           gfc_error ("NULL appears on right-hand side in assignment at %L",
2960                      &rvalue->where);
2961           return FAILURE;
2962         }
2963     }
2964
2965    if (sym->attr.cray_pointee
2966        && lvalue->ref != NULL
2967        && lvalue->ref->u.ar.type == AR_FULL
2968        && lvalue->ref->u.ar.as->cp_was_assumed)
2969      {
2970        gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2971                   "is illegal", &lvalue->where);
2972        return FAILURE;
2973      }
2974
2975   /* This is possibly a typo: x = f() instead of x => f().  */
2976   if (gfc_option.warn_surprising
2977       && rvalue->expr_type == EXPR_FUNCTION
2978       && rvalue->symtree->n.sym->attr.pointer)
2979     gfc_warning ("POINTER valued function appears on right-hand side of "
2980                  "assignment at %L", &rvalue->where);
2981
2982   /* Check size of array assignments.  */
2983   if (lvalue->rank != 0 && rvalue->rank != 0
2984       && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
2985     return FAILURE;
2986
2987   if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
2988       && lvalue->symtree->n.sym->attr.data
2989       && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
2990                          "initialize non-integer variable '%s'",
2991                          &rvalue->where, lvalue->symtree->n.sym->name)
2992          == FAILURE)
2993     return FAILURE;
2994   else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
2995       && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
2996                          "a DATA statement and outside INT/REAL/DBLE/CMPLX",
2997                          &rvalue->where) == FAILURE)
2998     return FAILURE;
2999
3000   /* Handle the case of a BOZ literal on the RHS.  */
3001   if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
3002     {
3003       int rc;
3004       if (gfc_option.warn_surprising)
3005         gfc_warning ("BOZ literal at %L is bitwise transferred "
3006                      "non-integer symbol '%s'", &rvalue->where,
3007                      lvalue->symtree->n.sym->name);
3008       if (!gfc_convert_boz (rvalue, &lvalue->ts))
3009         return FAILURE;
3010       if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
3011         {
3012           if (rc == ARITH_UNDERFLOW)
3013             gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3014                        ". This check can be disabled with the option "
3015                        "-fno-range-check", &rvalue->where);
3016           else if (rc == ARITH_OVERFLOW)
3017             gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3018                        ". This check can be disabled with the option "
3019                        "-fno-range-check", &rvalue->where);
3020           else if (rc == ARITH_NAN)
3021             gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3022                        ". This check can be disabled with the option "
3023                        "-fno-range-check", &rvalue->where);
3024           return FAILURE;
3025         }
3026     }
3027
3028   if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
3029     return SUCCESS;
3030
3031   /* Only DATA Statements come here.  */
3032   if (!conform)
3033     {
3034       /* Numeric can be converted to any other numeric. And Hollerith can be
3035          converted to any other type.  */
3036       if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
3037           || rvalue->ts.type == BT_HOLLERITH)
3038         return SUCCESS;
3039
3040       if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3041         return SUCCESS;
3042
3043       gfc_error ("Incompatible types in DATA statement at %L; attempted "
3044                  "conversion of %s to %s", &lvalue->where,
3045                  gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3046
3047       return FAILURE;
3048     }
3049
3050   /* Assignment is the only case where character variables of different
3051      kind values can be converted into one another.  */
3052   if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3053     {
3054       if (lvalue->ts.kind != rvalue->ts.kind)
3055         gfc_convert_chartype (rvalue, &lvalue->ts);
3056
3057       return SUCCESS;
3058     }
3059
3060   return gfc_convert_type (rvalue, &lvalue->ts, 1);
3061 }
3062
3063
3064 /* Check that a pointer assignment is OK.  We first check lvalue, and
3065    we only check rvalue if it's not an assignment to NULL() or a
3066    NULLIFY statement.  */
3067
3068 gfc_try
3069 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3070 {
3071   symbol_attribute attr;
3072   gfc_ref *ref;
3073   int is_pure;
3074   int pointer, check_intent_in, proc_pointer;
3075
3076   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3077       && !lvalue->symtree->n.sym->attr.proc_pointer)
3078     {
3079       gfc_error ("Pointer assignment target is not a POINTER at %L",
3080                  &lvalue->where);
3081       return FAILURE;
3082     }
3083
3084   if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
3085       && lvalue->symtree->n.sym->attr.use_assoc
3086       && !lvalue->symtree->n.sym->attr.proc_pointer)
3087     {
3088       gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3089                  "l-value since it is a procedure",
3090                  lvalue->symtree->n.sym->name, &lvalue->where);
3091       return FAILURE;
3092     }
3093
3094
3095   /* Check INTENT(IN), unless the object itself is the component or
3096      sub-component of a pointer.  */
3097   check_intent_in = 1;
3098   pointer = lvalue->symtree->n.sym->attr.pointer;
3099   proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3100
3101   for (ref = lvalue->ref; ref; ref = ref->next)
3102     {
3103       if (pointer)
3104         check_intent_in = 0;
3105
3106       if (ref->type == REF_COMPONENT)
3107         {
3108           pointer = ref->u.c.component->attr.pointer;
3109           proc_pointer = ref->u.c.component->attr.proc_pointer;
3110         }
3111
3112       if (ref->type == REF_ARRAY && ref->next == NULL)
3113         {
3114           if (ref->u.ar.type == AR_FULL)
3115             break;
3116
3117           if (ref->u.ar.type != AR_SECTION)
3118             {
3119               gfc_error ("Expected bounds specification for '%s' at %L",
3120                          lvalue->symtree->n.sym->name, &lvalue->where);
3121               return FAILURE;
3122             }
3123
3124           if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3125                               "specification for '%s' in pointer assignment "
3126                               "at %L", lvalue->symtree->n.sym->name,
3127                               &lvalue->where) == FAILURE)
3128             return FAILURE;
3129
3130           gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3131                      "in gfortran", &lvalue->where);
3132           /* TODO: See PR 29785. Add checks that all lbounds are specified and
3133              either never or always the upper-bound; strides shall not be
3134              present.  */
3135           return FAILURE;
3136         }
3137     }
3138
3139   if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
3140     {
3141       gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3142                  lvalue->symtree->n.sym->name, &lvalue->where);
3143       return FAILURE;
3144     }
3145
3146   if (!pointer && !proc_pointer
3147         && !(lvalue->ts.type == BT_CLASS
3148                 && lvalue->ts.u.derived->components->attr.pointer))
3149     {
3150       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
3151       return FAILURE;
3152     }
3153
3154   is_pure = gfc_pure (NULL);
3155
3156   if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
3157         && lvalue->symtree->n.sym->value != rvalue)
3158     {
3159       gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
3160       return FAILURE;
3161     }
3162
3163   /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3164      kind, etc for lvalue and rvalue must match, and rvalue must be a
3165      pure variable if we're in a pure function.  */
3166   if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3167     return SUCCESS;
3168
3169   /* Checks on rvalue for procedure pointer assignments.  */
3170   if (proc_pointer)
3171     {
3172       char err[200];
3173       gfc_symbol *s1,*s2;
3174       gfc_component *comp;
3175       const char *name;
3176
3177       attr = gfc_expr_attr (rvalue);
3178       if (!((rvalue->expr_type == EXPR_NULL)
3179             || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3180             || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
3181             || (rvalue->expr_type == EXPR_VARIABLE
3182                 && attr.flavor == FL_PROCEDURE)))
3183         {
3184           gfc_error ("Invalid procedure pointer assignment at %L",
3185                      &rvalue->where);
3186           return FAILURE;
3187         }
3188       if (attr.abstract)
3189         {
3190           gfc_error ("Abstract interface '%s' is invalid "
3191                      "in procedure pointer assignment at %L",
3192                      rvalue->symtree->name, &rvalue->where);
3193           return FAILURE;
3194         }
3195       /* Check for C727.  */
3196       if (attr.flavor == FL_PROCEDURE)
3197         {
3198           if (attr.proc == PROC_ST_FUNCTION)
3199             {
3200               gfc_error ("Statement function '%s' is invalid "
3201                          "in procedure pointer assignment at %L",
3202                          rvalue->symtree->name, &rvalue->where);
3203               return FAILURE;
3204             }
3205           if (attr.proc == PROC_INTERNAL &&
3206               gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
3207                               "invalid in procedure pointer assignment at %L",
3208                               rvalue->symtree->name, &rvalue->where) == FAILURE)
3209             return FAILURE;
3210         }
3211
3212       /* Ensure that the calling convention is the same. As other attributes
3213          such as DLLEXPORT may differ, one explicitly only tests for the
3214          calling conventions.  */
3215       if (rvalue->expr_type == EXPR_VARIABLE
3216           && lvalue->symtree->n.sym->attr.ext_attr
3217                != rvalue->symtree->n.sym->attr.ext_attr)
3218         {
3219           symbol_attribute calls;
3220
3221           calls.ext_attr = 0;
3222           gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
3223           gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
3224           gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
3225
3226           if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
3227               != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
3228             {
3229               gfc_error ("Mismatch in the procedure pointer assignment "
3230                          "at %L: mismatch in the calling convention",
3231                          &rvalue->where);
3232           return FAILURE;
3233             }
3234         }
3235
3236       if (gfc_is_proc_ptr_comp (lvalue, &comp))
3237         s1 = comp->ts.interface;
3238       else
3239         s1 = lvalue->symtree->n.sym;
3240
3241       if (gfc_is_proc_ptr_comp (rvalue, &comp))
3242         {
3243           s2 = comp->ts.interface;
3244           name = comp->name;
3245         }
3246       else if (rvalue->expr_type == EXPR_FUNCTION)
3247         {
3248           s2 = rvalue->symtree->n.sym->result;
3249           name = rvalue->symtree->n.sym->result->name;
3250         }
3251       else
3252         {
3253           s2 = rvalue->symtree->n.sym;
3254           name = rvalue->symtree->n.sym->name;
3255         }
3256
3257       if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
3258                                                err, sizeof(err)))
3259         {
3260           gfc_error ("Interface mismatch in procedure pointer assignment "
3261                      "at %L: %s", &rvalue->where, err);
3262           return FAILURE;
3263         }
3264
3265       return SUCCESS;
3266     }
3267
3268   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3269     {
3270       gfc_error ("Different types in pointer assignment at %L; attempted "
3271                  "assignment of %s to %s", &lvalue->where,
3272                  gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3273       return FAILURE;
3274     }
3275
3276   if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
3277     {
3278       gfc_error ("Different kind type parameters in pointer "
3279                  "assignment at %L", &lvalue->where);
3280       return FAILURE;
3281     }
3282
3283   if (lvalue->rank != rvalue->rank)
3284     {
3285       gfc_error ("Different ranks in pointer assignment at %L",
3286                  &lvalue->where);
3287       return FAILURE;
3288     }
3289
3290   /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X).  */
3291   if (rvalue->expr_type == EXPR_NULL)
3292     return SUCCESS;
3293
3294   if (lvalue->ts.type == BT_CHARACTER)
3295     {
3296       gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3297       if (t == FAILURE)
3298         return FAILURE;
3299     }
3300
3301   if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3302     lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3303
3304   attr = gfc_expr_attr (rvalue);
3305   if (!attr.target && !attr.pointer)
3306     {
3307       gfc_error ("Pointer assignment target is neither TARGET "
3308                  "nor POINTER at %L", &rvalue->where);
3309       return FAILURE;
3310     }
3311
3312   if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3313     {
3314       gfc_error ("Bad target in pointer assignment in PURE "
3315                  "procedure at %L", &rvalue->where);
3316     }
3317
3318   if (gfc_has_vector_index (rvalue))
3319     {
3320       gfc_error ("Pointer assignment with vector subscript "
3321                  "on rhs at %L", &rvalue->where);
3322       return FAILURE;
3323     }
3324
3325   if (attr.is_protected && attr.use_assoc
3326       && !(attr.pointer || attr.proc_pointer))
3327     {
3328       gfc_error ("Pointer assignment target has PROTECTED "
3329                  "attribute at %L", &rvalue->where);
3330       return FAILURE;
3331     }
3332
3333   return SUCCESS;
3334 }
3335
3336
3337 /* Relative of gfc_check_assign() except that the lvalue is a single
3338    symbol.  Used for initialization assignments.  */
3339
3340 gfc_try
3341 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3342 {
3343   gfc_expr lvalue;
3344   gfc_try r;
3345
3346   memset (&lvalue, '\0', sizeof (gfc_expr));
3347
3348   lvalue.expr_type = EXPR_VARIABLE;
3349   lvalue.ts = sym->ts;
3350   if (sym->as)
3351     lvalue.rank = sym->as->rank;
3352   lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3353   lvalue.symtree->n.sym = sym;
3354   lvalue.where = sym->declared_at;
3355
3356   if (sym->attr.pointer || sym->attr.proc_pointer
3357       || (sym->ts.type == BT_CLASS
3358           && sym->ts.u.derived->components->attr.pointer
3359           && rvalue->expr_type == EXPR_NULL))
3360     r = gfc_check_pointer_assign (&lvalue, rvalue);
3361   else
3362     r = gfc_check_assign (&lvalue, rvalue, 1);
3363
3364   gfc_free (lvalue.symtree);
3365
3366   return r;
3367 }
3368
3369
3370 /* Get an expression for a default initializer.  */
3371
3372 gfc_expr *
3373 gfc_default_initializer (gfc_typespec *ts)
3374 {
3375   gfc_constructor *tail;
3376   gfc_expr *init;
3377   gfc_component *c;
3378
3379   /* See if we have a default initializer.  */
3380   for (c = ts->u.derived->components; c; c = c->next)
3381     if (c->initializer || c->attr.allocatable)
3382       break;
3383
3384   if (!c)
3385     return NULL;
3386
3387   /* Build the constructor.  */
3388   init = gfc_get_expr ();
3389   init->expr_type = EXPR_STRUCTURE;
3390   init->ts = *ts;
3391   init->where = ts->u.derived->declared_at;
3392
3393   tail = NULL;
3394   for (c = ts->u.derived->components; c; c = c->next)
3395     {
3396       if (tail == NULL)
3397         init->value.constructor = tail = gfc_get_constructor ();
3398       else
3399         {
3400           tail->next = gfc_get_constructor ();
3401           tail = tail->next;
3402         }
3403
3404       if (c->initializer)
3405         tail->expr = gfc_copy_expr (c->initializer);
3406
3407       if (c->attr.allocatable)
3408         {
3409           tail->expr = gfc_get_expr ();
3410           tail->expr->expr_type = EXPR_NULL;
3411           tail->expr->ts = c->ts;
3412         }
3413     }
3414   return init;
3415 }
3416
3417
3418 /* Given a symbol, create an expression node with that symbol as a
3419    variable. If the symbol is array valued, setup a reference of the
3420    whole array.  */
3421
3422 gfc_expr *
3423 gfc_get_variable_expr (gfc_symtree *var)
3424 {
3425   gfc_expr *e;
3426
3427   e = gfc_get_expr ();
3428   e->expr_type = EXPR_VARIABLE;
3429   e->symtree = var;
3430   e->ts = var->n.sym->ts;
3431
3432   if (var->n.sym->as != NULL)
3433     {
3434       e->rank = var->n.sym->as->rank;
3435       e->ref = gfc_get_ref ();
3436       e->ref->type = REF_ARRAY;
3437       e->ref->u.ar.type = AR_FULL;
3438     }
3439
3440   return e;
3441 }
3442
3443
3444 /* General expression traversal function.  */
3445
3446 bool
3447 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3448                    bool (*func)(gfc_expr *, gfc_symbol *, int*),
3449                    int f)
3450 {
3451   gfc_array_ref ar;
3452   gfc_ref *ref;
3453   gfc_actual_arglist *args;
3454   gfc_constructor *c;
3455   int i;
3456
3457   if (!expr)
3458     return false;
3459
3460   if ((*func) (expr, sym, &f))
3461     return true;
3462
3463   if (expr->ts.type == BT_CHARACTER
3464         && expr->ts.u.cl
3465         && expr->ts.u.cl->length
3466         && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
3467         && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
3468     return true;
3469
3470   switch (expr->expr_type)
3471     {
3472     case EXPR_FUNCTION:
3473       for (args = expr->value.function.actual; args; args = args->next)
3474         {
3475           if (gfc_traverse_expr (args->expr, sym, func, f))
3476             return true;
3477         }
3478       break;
3479
3480     case EXPR_VARIABLE:
3481     case EXPR_CONSTANT:
3482     case EXPR_NULL:
3483     case EXPR_SUBSTRING:
3484       break;
3485
3486     case EXPR_STRUCTURE:
3487     case EXPR_ARRAY:
3488       for (c = expr->value.constructor; c; c = c->next)
3489         {
3490           if (gfc_traverse_expr (c->expr, sym, func, f))
3491             return true;
3492           if (c->iterator)
3493             {
3494               if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3495                 return true;
3496               if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3497                 return true;
3498               if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3499                 return true;
3500               if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3501                 return true;
3502             }
3503         }
3504       break;
3505
3506     case EXPR_OP:
3507       if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3508         return true;
3509       if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3510         return true;
3511       break;
3512
3513     default:
3514       gcc_unreachable ();
3515       break;
3516     }
3517
3518   ref = expr->ref;
3519   while (ref != NULL)
3520     {
3521       switch (ref->type)
3522         {
3523         case  REF_ARRAY:
3524           ar = ref->u.ar;
3525           for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3526             {
3527               if (gfc_traverse_expr (ar.start[i], sym, func, f))
3528                 return true;
3529               if (gfc_traverse_expr (ar.end[i], sym, func, f))
3530                 return true;
3531               if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3532                 return true;
3533             }
3534           break;
3535
3536         case REF_SUBSTRING:
3537           if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3538             return true;
3539           if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3540             return true;
3541           break;
3542
3543         case REF_COMPONENT:
3544           if (ref->u.c.component->ts.type == BT_CHARACTER
3545                 && ref->u.c.component->ts.u.cl
3546                 && ref->u.c.component->ts.u.cl->length
3547                 && ref->u.c.component->ts.u.cl->length->expr_type
3548                      != EXPR_CONSTANT
3549                 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
3550                                       sym, func, f))
3551             return true;
3552
3553           if (ref->u.c.component->as)
3554             for (i = 0; i < ref->u.c.component->as->rank; i++)
3555               {
3556                 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3557                                        sym, func, f))
3558                   return true;
3559                 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3560                                        sym, func, f))
3561                   return true;
3562               }
3563           break;
3564
3565         default:
3566           gcc_unreachable ();
3567         }
3568       ref = ref->next;
3569     }
3570   return false;
3571 }
3572
3573 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
3574
3575 static bool
3576 expr_set_symbols_referenced (gfc_expr *expr,
3577                              gfc_symbol *sym ATTRIBUTE_UNUSED,
3578                              int *f ATTRIBUTE_UNUSED)
3579 {
3580   if (expr->expr_type != EXPR_VARIABLE)
3581     return false;
3582   gfc_set_sym_referenced (expr->symtree->n.sym);
3583   return false;
3584 }
3585
3586 void
3587 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3588 {
3589   gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3590 }
3591
3592
3593 /* Determine if an expression is a procedure pointer component. If yes, the
3594    argument 'comp' will point to the component (provided that 'comp' was
3595    provided).  */
3596
3597 bool
3598 gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
3599 {
3600   gfc_ref *ref;
3601   bool ppc = false;
3602
3603   if (!expr || !expr->ref)
3604     return false;
3605
3606   ref = expr->ref;
3607   while (ref->next)
3608     ref = ref->next;
3609
3610   if (ref->type == REF_COMPONENT)
3611     {
3612       ppc = ref->u.c.component->attr.proc_pointer;
3613       if (ppc && comp)
3614         *comp = ref->u.c.component;
3615     }
3616
3617   return ppc;
3618 }
3619
3620
3621 /* Walk an expression tree and check each variable encountered for being typed.
3622    If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3623    mode as is a basic arithmetic expression using those; this is for things in
3624    legacy-code like:
3625
3626      INTEGER :: arr(n), n
3627      INTEGER :: arr(n + 1), n
3628
3629    The namespace is needed for IMPLICIT typing.  */
3630
3631 static gfc_namespace* check_typed_ns;
3632
3633 static bool
3634 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3635                        int* f ATTRIBUTE_UNUSED)
3636 {
3637   gfc_try t;
3638
3639   if (e->expr_type != EXPR_VARIABLE)
3640     return false;
3641
3642   gcc_assert (e->symtree);
3643   t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
3644                               true, e->where);
3645
3646   return (t == FAILURE);
3647 }
3648
3649 gfc_try
3650 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
3651 {
3652   bool error_found;
3653
3654   /* If this is a top-level variable or EXPR_OP, do the check with strict given
3655      to us.  */
3656   if (!strict)
3657     {
3658       if (e->expr_type == EXPR_VARIABLE && !e->ref)
3659         return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
3660
3661       if (e->expr_type == EXPR_OP)
3662         {
3663           gfc_try t = SUCCESS;
3664
3665           gcc_assert (e->value.op.op1);
3666           t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
3667
3668           if (t == SUCCESS && e->value.op.op2)
3669             t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
3670
3671           return t;
3672         }
3673     }
3674
3675   /* Otherwise, walk the expression and do it strictly.  */
3676   check_typed_ns = ns;
3677   error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
3678
3679   return error_found ? FAILURE : SUCCESS;
3680 }
3681
3682 /* Walk an expression tree and replace all symbols with a corresponding symbol
3683    in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
3684    statements. The boolean return value is required by gfc_traverse_expr.  */
3685
3686 static bool
3687 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3688 {
3689   if ((expr->expr_type == EXPR_VARIABLE
3690        || (expr->expr_type == EXPR_FUNCTION
3691            && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3692       && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
3693     {
3694       gfc_symtree *stree;
3695       gfc_namespace *ns = sym->formal_ns;
3696       /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3697          the symtree rather than create a new one (and probably fail later).  */
3698       stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3699                                 expr->symtree->n.sym->name);
3700       gcc_assert (stree);
3701       stree->n.sym->attr = expr->symtree->n.sym->attr;
3702       expr->symtree = stree;
3703     }
3704   return false;
3705 }
3706
3707 void
3708 gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
3709 {
3710   gfc_traverse_expr (expr, dest, &replace_symbol, 0);
3711 }
3712
3713 /* The following is analogous to 'replace_symbol', and needed for copying
3714    interfaces for procedure pointer components. The argument 'sym' must formally
3715    be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
3716    However, it gets actually passed a gfc_component (i.e. the procedure pointer
3717    component in whose formal_ns the arguments have to be).  */
3718
3719 static bool
3720 replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3721 {
3722   gfc_component *comp;
3723   comp = (gfc_component *)sym;
3724   if ((expr->expr_type == EXPR_VARIABLE
3725        || (expr->expr_type == EXPR_FUNCTION
3726            && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3727       && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
3728     {
3729       gfc_symtree *stree;
3730       gfc_namespace *ns = comp->formal_ns;
3731       /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3732          the symtree rather than create a new one (and probably fail later).  */
3733       stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3734                                 expr->symtree->n.sym->name);
3735       gcc_assert (stree);
3736       stree->n.sym->attr = expr->symtree->n.sym->attr;
3737       expr->symtree = stree;
3738     }
3739   return false;
3740 }
3741
3742 void
3743 gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
3744 {
3745   gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
3746 }
3747