gcc/fortran/expr.c

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