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