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