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
1038       /* Check the bounds.  */
1039       if ((ar->as->upper[i]
1040            && ar->as->upper[i]->expr_type == EXPR_CONSTANT
1041            && mpz_cmp (e->value.integer,
1042                        ar->as->upper[i]->value.integer) > 0)
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               goto depart;
1072             }
1073           cons = cons->next;
1074         }
1075     }
1076
1077 depart:
1078   mpz_clear (delta);
1079   mpz_clear (offset);
1080   mpz_clear (span);
1081   mpz_clear (tmp);
1082   if (e)
1083     gfc_free_expr (e);
1084   *rval = cons;
1085   return t;
1086 }
1087
1088
1089 /* Find a component of a structure constructor.  */
1090
1091 static gfc_constructor *
1092 find_component_ref (gfc_constructor *cons, gfc_ref *ref)
1093 {
1094   gfc_component *comp;
1095   gfc_component *pick;
1096
1097   comp = ref->u.c.sym->components;
1098   pick = ref->u.c.component;
1099   while (comp != pick)
1100     {
1101       comp = comp->next;
1102       cons = cons->next;
1103     }
1104
1105   return cons;
1106 }
1107
1108
1109 /* Replace an expression with the contents of a constructor, removing
1110    the subobject reference in the process.  */
1111
1112 static void
1113 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
1114 {
1115   gfc_expr *e;
1116
1117   e = cons->expr;
1118   cons->expr = NULL;
1119   e->ref = p->ref->next;
1120   p->ref->next =  NULL;
1121   gfc_replace_expr (p, e);
1122 }
1123
1124
1125 /* Pull an array section out of an array constructor.  */
1126
1127 static gfc_try
1128 find_array_section (gfc_expr *expr, gfc_ref *ref)
1129 {
1130   int idx;
1131   int rank;
1132   int d;
1133   int shape_i;
1134   long unsigned one = 1;
1135   bool incr_ctr;
1136   mpz_t start[GFC_MAX_DIMENSIONS];
1137   mpz_t end[GFC_MAX_DIMENSIONS];
1138   mpz_t stride[GFC_MAX_DIMENSIONS];
1139   mpz_t delta[GFC_MAX_DIMENSIONS];
1140   mpz_t ctr[GFC_MAX_DIMENSIONS];
1141   mpz_t delta_mpz;
1142   mpz_t tmp_mpz;
1143   mpz_t nelts;
1144   mpz_t ptr;
1145   mpz_t index;
1146   gfc_constructor *cons;
1147   gfc_constructor *base;
1148   gfc_expr *begin;
1149   gfc_expr *finish;
1150   gfc_expr *step;
1151   gfc_expr *upper;
1152   gfc_expr *lower;
1153   gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
1154   gfc_try t;
1155
1156   t = SUCCESS;
1157
1158   base = expr->value.constructor;
1159   expr->value.constructor = NULL;
1160
1161   rank = ref->u.ar.as->rank;
1162
1163   if (expr->shape == NULL)
1164     expr->shape = gfc_get_shape (rank);
1165
1166   mpz_init_set_ui (delta_mpz, one);
1167   mpz_init_set_ui (nelts, one);
1168   mpz_init (tmp_mpz);
1169
1170   /* Do the initialization now, so that we can cleanup without
1171      keeping track of where we were.  */
1172   for (d = 0; d < rank; d++)
1173     {
1174       mpz_init (delta[d]);
1175       mpz_init (start[d]);
1176       mpz_init (end[d]);
1177       mpz_init (ctr[d]);
1178       mpz_init (stride[d]);
1179       vecsub[d] = NULL;
1180     }
1181
1182   /* Build the counters to clock through the array reference.  */
1183   shape_i = 0;
1184   for (d = 0; d < rank; d++)
1185     {
1186       /* Make this stretch of code easier on the eye!  */
1187       begin = ref->u.ar.start[d];
1188       finish = ref->u.ar.end[d];
1189       step = ref->u.ar.stride[d];
1190       lower = ref->u.ar.as->lower[d];
1191       upper = ref->u.ar.as->upper[d];
1192
1193       if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR)  /* Vector subscript.  */
1194         {
1195           gcc_assert (begin);
1196
1197           if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1198             {
1199               t = FAILURE;
1200               goto cleanup;
1201             }
1202
1203           gcc_assert (begin->rank == 1);
1204           gcc_assert (begin->shape);
1205
1206           vecsub[d] = begin->value.constructor;
1207           mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1208           mpz_mul (nelts, nelts, begin->shape[0]);
1209           mpz_set (expr->shape[shape_i++], begin->shape[0]);
1210
1211           /* Check bounds.  */
1212           for (c = vecsub[d]; c; c = c->next)
1213             {
1214               if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
1215                   || mpz_cmp (c->expr->value.integer,
1216                               lower->value.integer) < 0)
1217                 {
1218                   gfc_error ("index in dimension %d is out of bounds "
1219                              "at %L", d + 1, &ref->u.ar.c_where[d]);
1220                   t = FAILURE;
1221                   goto cleanup;
1222                 }
1223             }
1224         }
1225       else
1226         {
1227           if ((begin && begin->expr_type != EXPR_CONSTANT)
1228               || (finish && finish->expr_type != EXPR_CONSTANT)
1229               || (step && step->expr_type != EXPR_CONSTANT))
1230             {
1231               t = FAILURE;
1232               goto cleanup;
1233             }
1234
1235           /* Obtain the stride.  */
1236           if (step)
1237             mpz_set (stride[d], step->value.integer);
1238           else
1239             mpz_set_ui (stride[d], one);
1240
1241           if (mpz_cmp_ui (stride[d], 0) == 0)
1242             mpz_set_ui (stride[d], one);
1243
1244           /* Obtain the start value for the index.  */
1245           if (begin)
1246             mpz_set (start[d], begin->value.integer);
1247           else
1248             mpz_set (start[d], lower->value.integer);
1249
1250           mpz_set (ctr[d], start[d]);
1251
1252           /* Obtain the end value for the index.  */
1253           if (finish)
1254             mpz_set (end[d], finish->value.integer);
1255           else
1256             mpz_set (end[d], upper->value.integer);
1257
1258           /* Separate 'if' because elements sometimes arrive with
1259              non-null end.  */
1260           if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1261             mpz_set (end [d], begin->value.integer);
1262
1263           /* Check the bounds.  */
1264           if (mpz_cmp (ctr[d], upper->value.integer) > 0
1265               || mpz_cmp (end[d], upper->value.integer) > 0
1266               || mpz_cmp (ctr[d], lower->value.integer) < 0
1267               || mpz_cmp (end[d], lower->value.integer) < 0)
1268             {
1269               gfc_error ("index in dimension %d is out of bounds "
1270                          "at %L", d + 1, &ref->u.ar.c_where[d]);
1271               t = FAILURE;
1272               goto cleanup;
1273             }
1274
1275           /* Calculate the number of elements and the shape.  */
1276           mpz_set (tmp_mpz, stride[d]);
1277           mpz_add (tmp_mpz, end[d], tmp_mpz);
1278           mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1279           mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1280           mpz_mul (nelts, nelts, tmp_mpz);
1281
1282           /* An element reference reduces the rank of the expression; don't
1283              add anything to the shape array.  */
1284           if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1285             mpz_set (expr->shape[shape_i++], tmp_mpz);
1286         }
1287
1288       /* Calculate the 'stride' (=delta) for conversion of the
1289          counter values into the index along the constructor.  */
1290       mpz_set (delta[d], delta_mpz);
1291       mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1292       mpz_add_ui (tmp_mpz, tmp_mpz, one);
1293       mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1294     }
1295
1296   mpz_init (index);
1297   mpz_init (ptr);
1298   cons = base;
1299
1300   /* Now clock through the array reference, calculating the index in
1301      the source constructor and transferring the elements to the new
1302      constructor.  */
1303   for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1304     {
1305       if (ref->u.ar.offset)
1306         mpz_set (ptr, ref->u.ar.offset->value.integer);
1307       else
1308         mpz_init_set_ui (ptr, 0);
1309
1310       incr_ctr = true;
1311       for (d = 0; d < rank; d++)
1312         {
1313           mpz_set (tmp_mpz, ctr[d]);
1314           mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1315           mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1316           mpz_add (ptr, ptr, tmp_mpz);
1317
1318           if (!incr_ctr) continue;
1319
1320           if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript.  */
1321             {
1322               gcc_assert(vecsub[d]);
1323
1324               if (!vecsub[d]->next)
1325                 vecsub[d] = ref->u.ar.start[d]->value.constructor;
1326               else
1327                 {
1328                   vecsub[d] = vecsub[d]->next;
1329                   incr_ctr = false;
1330                 }
1331               mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1332             }
1333           else
1334             {
1335               mpz_add (ctr[d], ctr[d], stride[d]);
1336
1337               if (mpz_cmp_ui (stride[d], 0) > 0
1338                   ? mpz_cmp (ctr[d], end[d]) > 0
1339                   : mpz_cmp (ctr[d], end[d]) < 0)
1340                 mpz_set (ctr[d], start[d]);
1341               else
1342                 incr_ctr = false;
1343             }
1344         }
1345
1346       /* There must be a better way of dealing with negative strides
1347          than resetting the index and the constructor pointer!  */
1348       if (mpz_cmp (ptr, index) < 0)
1349         {
1350           mpz_set_ui (index, 0);
1351           cons = base;
1352         }
1353
1354       while (cons && cons->next && mpz_cmp (ptr, index) > 0)
1355         {
1356           mpz_add_ui (index, index, one);
1357           cons = cons->next;
1358         }
1359
1360       gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
1361     }
1362
1363   mpz_clear (ptr);
1364   mpz_clear (index);
1365
1366 cleanup:
1367
1368   mpz_clear (delta_mpz);
1369   mpz_clear (tmp_mpz);
1370   mpz_clear (nelts);
1371   for (d = 0; d < rank; d++)
1372     {
1373       mpz_clear (delta[d]);
1374       mpz_clear (start[d]);
1375       mpz_clear (end[d]);
1376       mpz_clear (ctr[d]);
1377       mpz_clear (stride[d]);
1378     }
1379   gfc_free_constructor (base);
1380   return t;
1381 }
1382
1383 /* Pull a substring out of an expression.  */
1384
1385 static gfc_try
1386 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1387 {
1388   int end;
1389   int start;
1390   int length;
1391   gfc_char_t *chr;
1392
1393   if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1394       || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1395     return FAILURE;
1396
1397   *newp = gfc_copy_expr (p);
1398   gfc_free ((*newp)->value.character.string);
1399
1400   end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1401   start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1402   length = end - start + 1;
1403
1404   chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
1405   (*newp)->value.character.length = length;
1406   memcpy (chr, &p->value.character.string[start - 1],
1407           length * sizeof (gfc_char_t));
1408   chr[length] = '\0';
1409   return SUCCESS;
1410 }
1411
1412
1413
1414 /* Simplify a subobject reference of a constructor.  This occurs when
1415    parameter variable values are substituted.  */
1416
1417 static gfc_try
1418 simplify_const_ref (gfc_expr *p)
1419 {
1420   gfc_constructor *cons;
1421   gfc_expr *newp;
1422
1423   while (p->ref)
1424     {
1425       switch (p->ref->type)
1426         {
1427         case REF_ARRAY:
1428           switch (p->ref->u.ar.type)
1429             {
1430             case AR_ELEMENT:
1431               if (find_array_element (p->value.constructor, &p->ref->u.ar,
1432                                       &cons) == FAILURE)
1433                 return FAILURE;
1434
1435               if (!cons)
1436                 return SUCCESS;
1437
1438               remove_subobject_ref (p, cons);
1439               break;
1440
1441             case AR_SECTION:
1442               if (find_array_section (p, p->ref) == FAILURE)
1443                 return FAILURE;
1444               p->ref->u.ar.type = AR_FULL;
1445
1446             /* Fall through.  */
1447
1448             case AR_FULL:
1449               if (p->ref->next != NULL
1450                   && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1451                 {
1452                   cons = p->value.constructor;
1453                   for (; cons; cons = cons->next)
1454                     {
1455                       cons->expr->ref = gfc_copy_ref (p->ref->next);
1456                       if (simplify_const_ref (cons->expr) == FAILURE)
1457                         return FAILURE;
1458                     }
1459
1460                   /* If this is a CHARACTER array and we possibly took a
1461                      substring out of it, update the type-spec's character
1462                      length according to the first element (as all should have
1463                      the same length).  */
1464                   if (p->ts.type == BT_CHARACTER)
1465                     {
1466                       int string_len;
1467
1468                       gcc_assert (p->ref->next);
1469                       gcc_assert (!p->ref->next->next);
1470                       gcc_assert (p->ref->next->type == REF_SUBSTRING);
1471
1472                       if (p->value.constructor)
1473                         {
1474                           const gfc_expr* first = p->value.constructor->expr;
1475                           gcc_assert (first->expr_type == EXPR_CONSTANT);
1476                           gcc_assert (first->ts.type == BT_CHARACTER);
1477                           string_len = first->value.character.length;
1478                         }
1479                       else
1480                         string_len = 0;
1481
1482                       if (!p->ts.cl)
1483                         {
1484                           p->ts.cl = gfc_get_charlen ();
1485                           p->ts.cl->next = NULL;
1486                           p->ts.cl->length = NULL;
1487                         }
1488                       gfc_free_expr (p->ts.cl->length);
1489                       p->ts.cl->length = gfc_int_expr (string_len);
1490                     }
1491                 }
1492               gfc_free_ref_list (p->ref);
1493               p->ref = NULL;
1494               break;
1495
1496             default:
1497               return SUCCESS;
1498             }
1499
1500           break;
1501
1502         case REF_COMPONENT:
1503           cons = find_component_ref (p->value.constructor, p->ref);
1504           remove_subobject_ref (p, cons);
1505           break;
1506
1507         case REF_SUBSTRING:
1508           if (find_substring_ref (p, &newp) == FAILURE)
1509             return FAILURE;
1510
1511           gfc_replace_expr (p, newp);
1512           gfc_free_ref_list (p->ref);
1513           p->ref = NULL;
1514           break;
1515         }
1516     }
1517
1518   return SUCCESS;
1519 }
1520
1521
1522 /* Simplify a chain of references.  */
1523
1524 static gfc_try
1525 simplify_ref_chain (gfc_ref *ref, int type)
1526 {
1527   int n;
1528
1529   for (; ref; ref = ref->next)
1530     {
1531       switch (ref->type)
1532         {
1533         case REF_ARRAY:
1534           for (n = 0; n < ref->u.ar.dimen; n++)
1535             {
1536               if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
1537                 return FAILURE;
1538               if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
1539                 return FAILURE;
1540               if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
1541                 return FAILURE;
1542             }
1543           break;
1544
1545         case REF_SUBSTRING:
1546           if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1547             return FAILURE;
1548           if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1549             return FAILURE;
1550           break;
1551
1552         default:
1553           break;
1554         }
1555     }
1556   return SUCCESS;
1557 }
1558
1559
1560 /* Try to substitute the value of a parameter variable.  */
1561
1562 static gfc_try
1563 simplify_parameter_variable (gfc_expr *p, int type)
1564 {
1565   gfc_expr *e;
1566   gfc_try t;
1567
1568   e = gfc_copy_expr (p->symtree->n.sym->value);
1569   if (e == NULL)
1570     return FAILURE;
1571
1572   e->rank = p->rank;
1573
1574   /* Do not copy subobject refs for constant.  */
1575   if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1576     e->ref = gfc_copy_ref (p->ref);
1577   t = gfc_simplify_expr (e, type);
1578
1579   /* Only use the simplification if it eliminated all subobject references.  */
1580   if (t == SUCCESS && !e->ref)
1581     gfc_replace_expr (p, e);
1582   else
1583     gfc_free_expr (e);
1584
1585   return t;
1586 }
1587
1588 /* Given an expression, simplify it by collapsing constant
1589    expressions.  Most simplification takes place when the expression
1590    tree is being constructed.  If an intrinsic function is simplified
1591    at some point, we get called again to collapse the result against
1592    other constants.
1593
1594    We work by recursively simplifying expression nodes, simplifying
1595    intrinsic functions where possible, which can lead to further
1596    constant collapsing.  If an operator has constant operand(s), we
1597    rip the expression apart, and rebuild it, hoping that it becomes
1598    something simpler.
1599
1600    The expression type is defined for:
1601      0   Basic expression parsing
1602      1   Simplifying array constructors -- will substitute
1603          iterator values.
1604    Returns FAILURE on error, SUCCESS otherwise.
1605    NOTE: Will return SUCCESS even if the expression can not be simplified.  */
1606
1607 gfc_try
1608 gfc_simplify_expr (gfc_expr *p, int type)
1609 {
1610   gfc_actual_arglist *ap;
1611
1612   if (p == NULL)
1613     return SUCCESS;
1614
1615   switch (p->expr_type)
1616     {
1617     case EXPR_CONSTANT:
1618     case EXPR_NULL:
1619       break;
1620
1621     case EXPR_FUNCTION:
1622       for (ap = p->value.function.actual; ap; ap = ap->next)
1623         if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1624           return FAILURE;
1625
1626       if (p->value.function.isym != NULL
1627           && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1628         return FAILURE;
1629
1630       break;
1631
1632     case EXPR_SUBSTRING:
1633       if (simplify_ref_chain (p->ref, type) == FAILURE)
1634         return FAILURE;
1635
1636       if (gfc_is_constant_expr (p))
1637         {
1638           gfc_char_t *s;
1639           int start, end;
1640
1641           if (p->ref && p->ref->u.ss.start)
1642             {
1643               gfc_extract_int (p->ref->u.ss.start, &start);
1644               start--;  /* Convert from one-based to zero-based.  */
1645             }
1646           else
1647             start = 0;
1648
1649           if (p->ref && p->ref->u.ss.end)
1650             gfc_extract_int (p->ref->u.ss.end, &end);
1651           else
1652             end = p->value.character.length;
1653
1654           s = gfc_get_wide_string (end - start + 2);
1655           memcpy (s, p->value.character.string + start,
1656                   (end - start) * sizeof (gfc_char_t));
1657           s[end - start + 1] = '\0';  /* TODO: C-style string.  */
1658           gfc_free (p->value.character.string);
1659           p->value.character.string = s;
1660           p->value.character.length = end - start;
1661           p->ts.cl = gfc_get_charlen ();
1662           p->ts.cl->next = gfc_current_ns->cl_list;
1663           gfc_current_ns->cl_list = p->ts.cl;
1664           p->ts.cl->length = gfc_int_expr (p->value.character.length);
1665           gfc_free_ref_list (p->ref);
1666           p->ref = NULL;
1667           p->expr_type = EXPR_CONSTANT;
1668         }
1669       break;
1670
1671     case EXPR_OP:
1672       if (simplify_intrinsic_op (p, type) == FAILURE)
1673         return FAILURE;
1674       break;
1675
1676     case EXPR_VARIABLE:
1677       /* Only substitute array parameter variables if we are in an
1678          initialization expression, or we want a subsection.  */
1679       if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1680           && (gfc_init_expr || p->ref
1681               || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1682         {
1683           if (simplify_parameter_variable (p, type) == FAILURE)
1684             return FAILURE;
1685           break;
1686         }
1687
1688       if (type == 1)
1689         {
1690           gfc_simplify_iterator_var (p);
1691         }
1692
1693       /* Simplify subcomponent references.  */
1694       if (simplify_ref_chain (p->ref, type) == FAILURE)
1695         return FAILURE;
1696
1697       break;
1698
1699     case EXPR_STRUCTURE:
1700     case EXPR_ARRAY:
1701       if (simplify_ref_chain (p->ref, type) == FAILURE)
1702         return FAILURE;
1703
1704       if (simplify_constructor (p->value.constructor, type) == FAILURE)
1705         return FAILURE;
1706
1707       if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
1708           && p->ref->u.ar.type == AR_FULL)
1709           gfc_expand_constructor (p);
1710
1711       if (simplify_const_ref (p) == FAILURE)
1712         return FAILURE;
1713
1714       break;
1715
1716     case EXPR_COMPCALL:
1717       gcc_unreachable ();
1718       break;
1719     }
1720
1721   return SUCCESS;
1722 }
1723
1724
1725 /* Returns the type of an expression with the exception that iterator
1726    variables are automatically integers no matter what else they may
1727    be declared as.  */
1728
1729 static bt
1730 et0 (gfc_expr *e)
1731 {
1732   if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1733     return BT_INTEGER;
1734
1735   return e->ts.type;
1736 }
1737
1738
1739 /* Check an intrinsic arithmetic operation to see if it is consistent
1740    with some type of expression.  */
1741
1742 static gfc_try check_init_expr (gfc_expr *);
1743
1744
1745 /* Scalarize an expression for an elemental intrinsic call.  */
1746
1747 static gfc_try
1748 scalarize_intrinsic_call (gfc_expr *e)
1749 {
1750   gfc_actual_arglist *a, *b;
1751   gfc_constructor *args[5], *ctor, *new_ctor;
1752   gfc_expr *expr, *old;
1753   int n, i, rank[5], array_arg;
1754
1755   /* Find which, if any, arguments are arrays.  Assume that the old
1756      expression carries the type information and that the first arg
1757      that is an array expression carries all the shape information.*/
1758   n = array_arg = 0;
1759   a = e->value.function.actual;
1760   for (; a; a = a->next)
1761     {
1762       n++;
1763       if (a->expr->expr_type != EXPR_ARRAY)
1764         continue;
1765       array_arg = n;
1766       expr = gfc_copy_expr (a->expr);
1767       break;
1768     }
1769
1770   if (!array_arg)
1771     return FAILURE;
1772
1773   old = gfc_copy_expr (e);
1774
1775   gfc_free_constructor (expr->value.constructor);
1776   expr->value.constructor = NULL;
1777
1778   expr->ts = old->ts;
1779   expr->where = old->where;
1780   expr->expr_type = EXPR_ARRAY;
1781
1782   /* Copy the array argument constructors into an array, with nulls
1783      for the scalars.  */
1784   n = 0;
1785   a = old->value.function.actual;
1786   for (; a; a = a->next)
1787     {
1788       /* Check that this is OK for an initialization expression.  */
1789       if (a->expr && check_init_expr (a->expr) == FAILURE)
1790         goto cleanup;
1791
1792       rank[n] = 0;
1793       if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
1794         {
1795           rank[n] = a->expr->rank;
1796           ctor = a->expr->symtree->n.sym->value->value.constructor;
1797           args[n] = gfc_copy_constructor (ctor);
1798         }
1799       else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
1800         {
1801           if (a->expr->rank)
1802             rank[n] = a->expr->rank;
1803           else
1804             rank[n] = 1;
1805           args[n] = gfc_copy_constructor (a->expr->value.constructor);
1806         }
1807       else
1808         args[n] = NULL;
1809       n++;
1810     }
1811
1812
1813   /* Using the array argument as the master, step through the array
1814      calling the function for each element and advancing the array
1815      constructors together.  */
1816   ctor = args[array_arg - 1];
1817   new_ctor = NULL;
1818   for (; ctor; ctor = ctor->next)
1819     {
1820           if (expr->value.constructor == NULL)
1821             expr->value.constructor
1822                 = new_ctor = gfc_get_constructor ();
1823           else
1824             {
1825               new_ctor->next = gfc_get_constructor ();
1826               new_ctor = new_ctor->next;
1827             }
1828           new_ctor->expr = gfc_copy_expr (old);
1829           gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
1830           a = NULL;
1831           b = old->value.function.actual;
1832           for (i = 0; i < n; i++)
1833             {
1834               if (a == NULL)
1835                 new_ctor->expr->value.function.actual
1836                         = a = gfc_get_actual_arglist ();
1837               else
1838                 {
1839                   a->next = gfc_get_actual_arglist ();
1840                   a = a->next;
1841                 }
1842               if (args[i])
1843                 a->expr = gfc_copy_expr (args[i]->expr);
1844               else
1845                 a->expr = gfc_copy_expr (b->expr);
1846
1847               b = b->next;
1848             }
1849
1850           /* Simplify the function calls.  If the simplification fails, the
1851              error will be flagged up down-stream or the library will deal
1852              with it.  */
1853           gfc_simplify_expr (new_ctor->expr, 0);
1854
1855           for (i = 0; i < n; i++)
1856             if (args[i])
1857               args[i] = args[i]->next;
1858
1859           for (i = 1; i < n; i++)
1860             if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
1861                          || (args[i] == NULL && args[array_arg - 1] != NULL)))
1862               goto compliance;
1863     }
1864
1865   free_expr0 (e);
1866   *e = *expr;
1867   gfc_free_expr (old);
1868   return SUCCESS;
1869
1870 compliance:
1871   gfc_error_now ("elemental function arguments at %C are not compliant");
1872
1873 cleanup:
1874   gfc_free_expr (expr);
1875   gfc_free_expr (old);
1876   return FAILURE;
1877 }
1878
1879
1880 static gfc_try
1881 check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
1882 {
1883   gfc_expr *op1 = e->value.op.op1;
1884   gfc_expr *op2 = e->value.op.op2;
1885
1886   if ((*check_function) (op1) == FAILURE)
1887     return FAILURE;
1888
1889   switch (e->value.op.op)
1890     {
1891     case INTRINSIC_UPLUS:
1892     case INTRINSIC_UMINUS:
1893       if (!numeric_type (et0 (op1)))
1894         goto not_numeric;
1895       break;
1896
1897     case INTRINSIC_EQ:
1898     case INTRINSIC_EQ_OS:
1899     case INTRINSIC_NE:
1900     case INTRINSIC_NE_OS:
1901     case INTRINSIC_GT:
1902     case INTRINSIC_GT_OS:
1903     case INTRINSIC_GE:
1904     case INTRINSIC_GE_OS:
1905     case INTRINSIC_LT:
1906     case INTRINSIC_LT_OS:
1907     case INTRINSIC_LE:
1908     case INTRINSIC_LE_OS:
1909       if ((*check_function) (op2) == FAILURE)
1910         return FAILURE;
1911
1912       if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
1913           && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
1914         {
1915           gfc_error ("Numeric or CHARACTER operands are required in "
1916                      "expression at %L", &e->where);
1917          return FAILURE;
1918         }
1919       break;
1920
1921     case INTRINSIC_PLUS:
1922     case INTRINSIC_MINUS:
1923     case INTRINSIC_TIMES:
1924     case INTRINSIC_DIVIDE:
1925     case INTRINSIC_POWER:
1926       if ((*check_function) (op2) == FAILURE)
1927         return FAILURE;
1928
1929       if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
1930         goto not_numeric;
1931
1932       if (e->value.op.op == INTRINSIC_POWER
1933           && check_function == check_init_expr && et0 (op2) != BT_INTEGER)
1934         {
1935           if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
1936                               "exponent in an initialization "
1937                               "expression at %L", &op2->where)
1938               == FAILURE)
1939             return FAILURE;
1940         }
1941
1942       break;
1943
1944     case INTRINSIC_CONCAT:
1945       if ((*check_function) (op2) == FAILURE)
1946         return FAILURE;
1947
1948       if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
1949         {
1950           gfc_error ("Concatenation operator in expression at %L "
1951                      "must have two CHARACTER operands", &op1->where);
1952           return FAILURE;
1953         }
1954
1955       if (op1->ts.kind != op2->ts.kind)
1956         {
1957           gfc_error ("Concat operator at %L must concatenate strings of the "
1958                      "same kind", &e->where);
1959           return FAILURE;
1960         }
1961
1962       break;
1963
1964     case INTRINSIC_NOT:
1965       if (et0 (op1) != BT_LOGICAL)
1966         {
1967           gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1968                      "operand", &op1->where);
1969           return FAILURE;
1970         }
1971
1972       break;
1973
1974     case INTRINSIC_AND:
1975     case INTRINSIC_OR:
1976     case INTRINSIC_EQV:
1977     case INTRINSIC_NEQV:
1978       if ((*check_function) (op2) == FAILURE)
1979         return FAILURE;
1980
1981       if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
1982         {
1983           gfc_error ("LOGICAL operands are required in expression at %L",
1984                      &e->where);
1985           return FAILURE;
1986         }
1987
1988       break;
1989
1990     case INTRINSIC_PARENTHESES:
1991       break;
1992
1993     default:
1994       gfc_error ("Only intrinsic operators can be used in expression at %L",
1995                  &e->where);
1996       return FAILURE;
1997     }
1998
1999   return SUCCESS;
2000
2001 not_numeric:
2002   gfc_error ("Numeric operands are required in expression at %L", &e->where);
2003
2004   return FAILURE;
2005 }
2006
2007
2008 static match
2009 check_init_expr_arguments (gfc_expr *e)
2010 {
2011   gfc_actual_arglist *ap;
2012
2013   for (ap = e->value.function.actual; ap; ap = ap->next)
2014     if (check_init_expr (ap->expr) == FAILURE)
2015       return MATCH_ERROR;
2016
2017   return MATCH_YES;
2018 }
2019
2020 static gfc_try check_restricted (gfc_expr *);
2021
2022 /* F95, 7.1.6.1, Initialization expressions, (7)
2023    F2003, 7.1.7 Initialization expression, (8)  */
2024
2025 static match
2026 check_inquiry (gfc_expr *e, int not_restricted)
2027 {
2028   const char *name;
2029   const char *const *functions;
2030
2031   static const char *const inquiry_func_f95[] = {
2032     "lbound", "shape", "size", "ubound",
2033     "bit_size", "len", "kind",
2034     "digits", "epsilon", "huge", "maxexponent", "minexponent",
2035     "precision", "radix", "range", "tiny",
2036     NULL
2037   };
2038
2039   static const char *const inquiry_func_f2003[] = {
2040     "lbound", "shape", "size", "ubound",
2041     "bit_size", "len", "kind",
2042     "digits", "epsilon", "huge", "maxexponent", "minexponent",
2043     "precision", "radix", "range", "tiny",
2044     "new_line", NULL
2045   };
2046
2047   int i;
2048   gfc_actual_arglist *ap;
2049
2050   if (!e->value.function.isym
2051       || !e->value.function.isym->inquiry)
2052     return MATCH_NO;
2053
2054   /* An undeclared parameter will get us here (PR25018).  */
2055   if (e->symtree == NULL)
2056     return MATCH_NO;
2057
2058   name = e->symtree->n.sym->name;
2059
2060   functions = (gfc_option.warn_std & GFC_STD_F2003)
2061                 ? inquiry_func_f2003 : inquiry_func_f95;
2062
2063   for (i = 0; functions[i]; i++)
2064     if (strcmp (functions[i], name) == 0)
2065       break;
2066
2067   if (functions[i] == NULL)
2068     return MATCH_ERROR;
2069
2070   /* At this point we have an inquiry function with a variable argument.  The
2071      type of the variable might be undefined, but we need it now, because the
2072      arguments of these functions are not allowed to be undefined.  */
2073
2074   for (ap = e->value.function.actual; ap; ap = ap->next)
2075     {
2076       if (!ap->expr)
2077         continue;
2078
2079       if (ap->expr->ts.type == BT_UNKNOWN)
2080         {
2081           if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2082               && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)
2083               == FAILURE)
2084             return MATCH_NO;
2085
2086           ap->expr->ts = ap->expr->symtree->n.sym->ts;
2087         }
2088
2089         /* Assumed character length will not reduce to a constant expression
2090            with LEN, as required by the standard.  */
2091         if (i == 5 && not_restricted
2092             && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2093             && ap->expr->symtree->n.sym->ts.cl->length == NULL)
2094           {
2095             gfc_error ("Assumed character length variable '%s' in constant "
2096                        "expression at %L", e->symtree->n.sym->name, &e->where);
2097               return MATCH_ERROR;
2098           }
2099         else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
2100           return MATCH_ERROR;
2101
2102         if (not_restricted == 0
2103               && ap->expr->expr_type != EXPR_VARIABLE
2104               && check_restricted (ap->expr) == FAILURE)
2105           return MATCH_ERROR;
2106     }
2107
2108   return MATCH_YES;
2109 }
2110
2111
2112 /* F95, 7.1.6.1, Initialization expressions, (5)
2113    F2003, 7.1.7 Initialization expression, (5)  */
2114
2115 static match
2116 check_transformational (gfc_expr *e)
2117 {
2118   static const char * const trans_func_f95[] = {
2119     "repeat", "reshape", "selected_int_kind",
2120     "selected_real_kind", "transfer", "trim", NULL
2121   };
2122
2123   int i;
2124   const char *name;
2125
2126   if (!e->value.function.isym
2127       || !e->value.function.isym->transformational)
2128     return MATCH_NO;
2129
2130   name = e->symtree->n.sym->name;
2131
2132   /* NULL() is dealt with below.  */
2133   if (strcmp ("null", name) == 0)
2134     return MATCH_NO;
2135
2136   for (i = 0; trans_func_f95[i]; i++)
2137     if (strcmp (trans_func_f95[i], name) == 0)
2138       break;
2139
2140   /* FIXME, F2003: implement translation of initialization
2141      expressions before enabling this check. For F95, error
2142      out if the transformational function is not in the list.  */
2143 #if 0
2144   if (trans_func_f95[i] == NULL
2145       && gfc_notify_std (GFC_STD_F2003,
2146                          "transformational intrinsic '%s' at %L is not permitted "
2147                          "in an initialization expression", name, &e->where) == FAILURE)
2148     return MATCH_ERROR;
2149 #else
2150   if (trans_func_f95[i] == NULL)
2151     {
2152       gfc_error("transformational intrinsic '%s' at %L is not permitted "
2153                 "in an initialization expression", name, &e->where);
2154       return MATCH_ERROR;
2155     }
2156 #endif
2157
2158   return check_init_expr_arguments (e);
2159 }
2160
2161
2162 /* F95, 7.1.6.1, Initialization expressions, (6)
2163    F2003, 7.1.7 Initialization expression, (6)  */
2164
2165 static match
2166 check_null (gfc_expr *e)
2167 {
2168   if (strcmp ("null", e->symtree->n.sym->name) != 0)
2169     return MATCH_NO;
2170
2171   return check_init_expr_arguments (e);
2172 }
2173
2174
2175 static match
2176 check_elemental (gfc_expr *e)
2177 {
2178   if (!e->value.function.isym
2179       || !e->value.function.isym->elemental)
2180     return MATCH_NO;
2181
2182   if (e->ts.type != BT_INTEGER
2183       && e->ts.type != BT_CHARACTER
2184       && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
2185                         "nonstandard initialization expression at %L",
2186                         &e->where) == FAILURE)
2187     return MATCH_ERROR;
2188
2189   return check_init_expr_arguments (e);
2190 }
2191
2192
2193 static match
2194 check_conversion (gfc_expr *e)
2195 {
2196   if (!e->value.function.isym
2197       || !e->value.function.isym->conversion)
2198     return MATCH_NO;
2199
2200   return check_init_expr_arguments (e);
2201 }
2202
2203
2204 /* Verify that an expression is an initialization expression.  A side
2205    effect is that the expression tree is reduced to a single constant
2206    node if all goes well.  This would normally happen when the
2207    expression is constructed but function references are assumed to be
2208    intrinsics in the context of initialization expressions.  If
2209    FAILURE is returned an error message has been generated.  */
2210
2211 static gfc_try
2212 check_init_expr (gfc_expr *e)
2213 {
2214   match m;
2215   gfc_try t;
2216
2217   if (e == NULL)
2218     return SUCCESS;
2219
2220   switch (e->expr_type)
2221     {
2222     case EXPR_OP:
2223       t = check_intrinsic_op (e, check_init_expr);
2224       if (t == SUCCESS)
2225         t = gfc_simplify_expr (e, 0);
2226
2227       break;
2228
2229     case EXPR_FUNCTION:
2230       t = FAILURE;
2231
2232       if ((m = check_specification_function (e)) != MATCH_YES)
2233         {
2234           gfc_intrinsic_sym* isym;
2235           gfc_symbol* sym;
2236
2237           sym = e->symtree->n.sym;
2238           if (!gfc_is_intrinsic (sym, 0, e->where)
2239               || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
2240             {
2241               gfc_error ("Function '%s' in initialization expression at %L "
2242                          "must be an intrinsic or a specification function",
2243                          e->symtree->n.sym->name, &e->where);
2244               break;
2245             }
2246
2247           if ((m = check_conversion (e)) == MATCH_NO
2248               && (m = check_inquiry (e, 1)) == MATCH_NO
2249               && (m = check_null (e)) == MATCH_NO
2250               && (m = check_transformational (e)) == MATCH_NO
2251               && (m = check_elemental (e)) == MATCH_NO)
2252             {
2253               gfc_error ("Intrinsic function '%s' at %L is not permitted "
2254                          "in an initialization expression",
2255                          e->symtree->n.sym->name, &e->where);
2256               m = MATCH_ERROR;
2257             }
2258
2259           /* Try to scalarize an elemental intrinsic function that has an
2260              array argument.  */
2261           isym = gfc_find_function (e->symtree->n.sym->name);
2262           if (isym && isym->elemental
2263                 && (t = scalarize_intrinsic_call (e)) == SUCCESS)
2264             break;
2265         }
2266
2267       if (m == MATCH_YES)
2268         t = gfc_simplify_expr (e, 0);
2269
2270       break;
2271
2272     case EXPR_VARIABLE:
2273       t = SUCCESS;
2274
2275       if (gfc_check_iter_variable (e) == SUCCESS)
2276         break;
2277
2278       if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2279         {
2280           /* A PARAMETER shall not be used to define itself, i.e.
2281                 REAL, PARAMETER :: x = transfer(0, x)
2282              is invalid.  */
2283           if (!e->symtree->n.sym->value)
2284             {
2285               gfc_error("PARAMETER '%s' is used at %L before its definition "
2286                         "is complete", e->symtree->n.sym->name, &e->where);
2287               t = FAILURE;
2288             }
2289           else
2290             t = simplify_parameter_variable (e, 0);
2291
2292           break;
2293         }
2294
2295       if (gfc_in_match_data ())
2296         break;
2297
2298       t = FAILURE;
2299
2300       if (e->symtree->n.sym->as)
2301         {
2302           switch (e->symtree->n.sym->as->type)
2303             {
2304               case AS_ASSUMED_SIZE:
2305                 gfc_error ("Assumed size 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_ASSUMED_SHAPE:
2311                 gfc_error ("Assumed shape 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_DEFERRED:
2317                 gfc_error ("Deferred array '%s' at %L is not permitted "
2318                            "in an initialization expression",
2319                            e->symtree->n.sym->name, &e->where);
2320                 break;
2321
2322               case AS_EXPLICIT:
2323                 gfc_error ("Array '%s' at %L is a variable, which does "
2324                            "not reduce to a constant expression",
2325                            e->symtree->n.sym->name, &e->where);
2326                 break;
2327
2328               default:
2329                 gcc_unreachable();
2330           }
2331         }
2332       else
2333         gfc_error ("Parameter '%s' at %L has not been declared or is "
2334                    "a variable, which does not reduce to a constant "
2335                    "expression", e->symtree->n.sym->name, &e->where);
2336
2337       break;
2338
2339     case EXPR_CONSTANT:
2340     case EXPR_NULL:
2341       t = SUCCESS;
2342       break;
2343
2344     case EXPR_SUBSTRING:
2345       t = check_init_expr (e->ref->u.ss.start);
2346       if (t == FAILURE)
2347         break;
2348
2349       t = check_init_expr (e->ref->u.ss.end);
2350       if (t == SUCCESS)
2351         t = gfc_simplify_expr (e, 0);
2352
2353       break;
2354
2355     case EXPR_STRUCTURE:
2356       if (e->ts.is_iso_c)
2357         t = SUCCESS;
2358       else
2359         t = gfc_check_constructor (e, check_init_expr);
2360       break;
2361
2362     case EXPR_ARRAY:
2363       t = gfc_check_constructor (e, check_init_expr);
2364       if (t == FAILURE)
2365         break;
2366
2367       t = gfc_expand_constructor (e);
2368       if (t == FAILURE)
2369         break;
2370
2371       t = gfc_check_constructor_type (e);
2372       break;
2373
2374     default:
2375       gfc_internal_error ("check_init_expr(): Unknown expression type");
2376     }
2377
2378   return t;
2379 }
2380
2381 /* Reduces a general expression to an initialization expression (a constant).
2382    This used to be part of gfc_match_init_expr.
2383    Note that this function doesn't free the given expression on FAILURE.  */
2384
2385 gfc_try
2386 gfc_reduce_init_expr (gfc_expr *expr)
2387 {
2388   gfc_try t;
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     return FAILURE;
2398
2399   if (expr->expr_type == EXPR_ARRAY
2400       && (gfc_check_constructor_type (expr) == FAILURE
2401       || gfc_expand_constructor (expr) == FAILURE))
2402     return FAILURE;
2403
2404   /* Not all inquiry functions are simplified to constant expressions
2405      so it is necessary to call check_inquiry again.  */
2406   if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) != MATCH_YES
2407       && !gfc_in_match_data ())
2408     {
2409       gfc_error ("Initialization expression didn't reduce %C");
2410       return FAILURE;
2411     }
2412
2413   return SUCCESS;
2414 }
2415
2416
2417 /* Match an initialization expression.  We work by first matching an
2418    expression, then reducing it to a constant.  */
2419
2420 match
2421 gfc_match_init_expr (gfc_expr **result)
2422 {
2423   gfc_expr *expr;
2424   match m;
2425   gfc_try t;
2426
2427   expr = NULL;
2428
2429   m = gfc_match_expr (&expr);
2430   if (m != MATCH_YES)
2431     return m;
2432
2433   t = gfc_reduce_init_expr (expr);
2434   if (t != SUCCESS)
2435     {
2436       gfc_free_expr (expr);
2437       return MATCH_ERROR;
2438     }
2439
2440   *result = expr;
2441
2442   return MATCH_YES;
2443 }
2444
2445
2446 /* Given an actual argument list, test to see that each argument is a
2447    restricted expression and optionally if the expression type is
2448    integer or character.  */
2449
2450 static gfc_try
2451 restricted_args (gfc_actual_arglist *a)
2452 {
2453   for (; a; a = a->next)
2454     {
2455       if (check_restricted (a->expr) == FAILURE)
2456         return FAILURE;
2457     }
2458
2459   return SUCCESS;
2460 }
2461
2462
2463 /************* Restricted/specification expressions *************/
2464
2465
2466 /* Make sure a non-intrinsic function is a specification function.  */
2467
2468 static gfc_try
2469 external_spec_function (gfc_expr *e)
2470 {
2471   gfc_symbol *f;
2472
2473   f = e->value.function.esym;
2474
2475   if (f->attr.proc == PROC_ST_FUNCTION)
2476     {
2477       gfc_error ("Specification function '%s' at %L cannot be a statement "
2478                  "function", f->name, &e->where);
2479       return FAILURE;
2480     }
2481
2482   if (f->attr.proc == PROC_INTERNAL)
2483     {
2484       gfc_error ("Specification function '%s' at %L cannot be an internal "
2485                  "function", f->name, &e->where);
2486       return FAILURE;
2487     }
2488
2489   if (!f->attr.pure && !f->attr.elemental)
2490     {
2491       gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2492                  &e->where);
2493       return FAILURE;
2494     }
2495
2496   if (f->attr.recursive)
2497     {
2498       gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2499                  f->name, &e->where);
2500       return FAILURE;
2501     }
2502
2503   return restricted_args (e->value.function.actual);
2504 }
2505
2506
2507 /* Check to see that a function reference to an intrinsic is a
2508    restricted expression.  */
2509
2510 static gfc_try
2511 restricted_intrinsic (gfc_expr *e)
2512 {
2513   /* TODO: Check constraints on inquiry functions.  7.1.6.2 (7).  */
2514   if (check_inquiry (e, 0) == MATCH_YES)
2515     return SUCCESS;
2516
2517   return restricted_args (e->value.function.actual);
2518 }
2519
2520
2521 /* Check the expressions of an actual arglist.  Used by check_restricted.  */
2522
2523 static gfc_try
2524 check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
2525 {
2526   for (; arg; arg = arg->next)
2527     if (checker (arg->expr) == FAILURE)
2528       return FAILURE;
2529
2530   return SUCCESS;
2531 }
2532
2533
2534 /* Check the subscription expressions of a reference chain with a checking
2535    function; used by check_restricted.  */
2536
2537 static gfc_try
2538 check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
2539 {
2540   int dim;
2541
2542   if (!ref)
2543     return SUCCESS;
2544
2545   switch (ref->type)
2546     {
2547     case REF_ARRAY:
2548       for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2549         {
2550           if (checker (ref->u.ar.start[dim]) == FAILURE)
2551             return FAILURE;
2552           if (checker (ref->u.ar.end[dim]) == FAILURE)
2553             return FAILURE;
2554           if (checker (ref->u.ar.stride[dim]) == FAILURE)
2555             return FAILURE;
2556         }
2557       break;
2558
2559     case REF_COMPONENT:
2560       /* Nothing needed, just proceed to next reference.  */
2561       break;
2562
2563     case REF_SUBSTRING:
2564       if (checker (ref->u.ss.start) == FAILURE)
2565         return FAILURE;
2566       if (checker (ref->u.ss.end) == FAILURE)
2567         return FAILURE;
2568       break;
2569
2570     default:
2571       gcc_unreachable ();
2572       break;
2573     }
2574
2575   return check_references (ref->next, checker);
2576 }
2577
2578
2579 /* Verify that an expression is a restricted expression.  Like its
2580    cousin check_init_expr(), an error message is generated if we
2581    return FAILURE.  */
2582
2583 static gfc_try
2584 check_restricted (gfc_expr *e)
2585 {
2586   gfc_symbol* sym;
2587   gfc_try t;
2588
2589   if (e == NULL)
2590     return SUCCESS;
2591
2592   switch (e->expr_type)
2593     {
2594     case EXPR_OP:
2595       t = check_intrinsic_op (e, check_restricted);
2596       if (t == SUCCESS)
2597         t = gfc_simplify_expr (e, 0);
2598
2599       break;
2600
2601     case EXPR_FUNCTION:
2602       if (e->value.function.esym)
2603         {
2604           t = check_arglist (e->value.function.actual, &check_restricted);
2605           if (t == SUCCESS)
2606             t = external_spec_function (e);
2607         }
2608       else
2609         {
2610           if (e->value.function.isym && e->value.function.isym->inquiry)
2611             t = SUCCESS;
2612           else
2613             t = check_arglist (e->value.function.actual, &check_restricted);
2614
2615           if (t == SUCCESS)
2616             t = restricted_intrinsic (e);
2617         }
2618       break;
2619
2620     case EXPR_VARIABLE:
2621       sym = e->symtree->n.sym;
2622       t = FAILURE;
2623
2624       /* If a dummy argument appears in a context that is valid for a
2625          restricted expression in an elemental procedure, it will have
2626          already been simplified away once we get here.  Therefore we
2627          don't need to jump through hoops to distinguish valid from
2628          invalid cases.  */
2629       if (sym->attr.dummy && sym->ns == gfc_current_ns
2630           && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
2631         {
2632           gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2633                      sym->name, &e->where);
2634           break;
2635         }
2636
2637       if (sym->attr.optional)
2638         {
2639           gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2640                      sym->name, &e->where);
2641           break;
2642         }
2643
2644       if (sym->attr.intent == INTENT_OUT)
2645         {
2646           gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2647                      sym->name, &e->where);
2648           break;
2649         }
2650
2651       /* Check reference chain if any.  */
2652       if (check_references (e->ref, &check_restricted) == FAILURE)
2653         break;
2654
2655       /* gfc_is_formal_arg broadcasts that a formal argument list is being
2656          processed in resolve.c(resolve_formal_arglist).  This is done so
2657          that host associated dummy array indices are accepted (PR23446).
2658          This mechanism also does the same for the specification expressions
2659          of array-valued functions.  */
2660       if (e->error
2661             || sym->attr.in_common
2662             || sym->attr.use_assoc
2663             || sym->attr.dummy
2664             || sym->attr.implied_index
2665             || sym->attr.flavor == FL_PARAMETER
2666             || (sym->ns && sym->ns == gfc_current_ns->parent)
2667             || (sym->ns && gfc_current_ns->parent
2668                   && sym->ns == gfc_current_ns->parent->parent)
2669             || (sym->ns->proc_name != NULL
2670                   && sym->ns->proc_name->attr.flavor == FL_MODULE)
2671             || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2672         {
2673           t = SUCCESS;
2674           break;
2675         }
2676
2677       gfc_error ("Variable '%s' cannot appear in the expression at %L",
2678                  sym->name, &e->where);
2679       /* Prevent a repetition of the error.  */
2680       e->error = 1;
2681       break;
2682
2683     case EXPR_NULL:
2684     case EXPR_CONSTANT:
2685       t = SUCCESS;
2686       break;
2687
2688     case EXPR_SUBSTRING:
2689       t = gfc_specification_expr (e->ref->u.ss.start);
2690       if (t == FAILURE)
2691         break;
2692
2693       t = gfc_specification_expr (e->ref->u.ss.end);
2694       if (t == SUCCESS)
2695         t = gfc_simplify_expr (e, 0);
2696
2697       break;
2698
2699     case EXPR_STRUCTURE:
2700       t = gfc_check_constructor (e, check_restricted);
2701       break;
2702
2703     case EXPR_ARRAY:
2704       t = gfc_check_constructor (e, check_restricted);
2705       break;
2706
2707     default:
2708       gfc_internal_error ("check_restricted(): Unknown expression type");
2709     }
2710
2711   return t;
2712 }
2713
2714
2715 /* Check to see that an expression is a specification expression.  If
2716    we return FAILURE, an error has been generated.  */
2717
2718 gfc_try
2719 gfc_specification_expr (gfc_expr *e)
2720 {
2721
2722   if (e == NULL)
2723     return SUCCESS;
2724
2725   if (e->ts.type != BT_INTEGER)
2726     {
2727       gfc_error ("Expression at %L must be of INTEGER type, found %s",
2728                  &e->where, gfc_basic_typename (e->ts.type));
2729       return FAILURE;
2730     }
2731
2732   if (e->expr_type == EXPR_FUNCTION
2733           && !e->value.function.isym
2734           && !e->value.function.esym
2735           && !gfc_pure (e->symtree->n.sym))
2736     {
2737       gfc_error ("Function '%s' at %L must be PURE",
2738                  e->symtree->n.sym->name, &e->where);
2739       /* Prevent repeat error messages.  */
2740       e->symtree->n.sym->attr.pure = 1;
2741       return FAILURE;
2742     }
2743
2744   if (e->rank != 0)
2745     {
2746       gfc_error ("Expression at %L must be scalar", &e->where);
2747       return FAILURE;
2748     }
2749
2750   if (gfc_simplify_expr (e, 0) == FAILURE)
2751     return FAILURE;
2752
2753   return check_restricted (e);
2754 }
2755
2756
2757 /************** Expression conformance checks.  *************/
2758
2759 /* Given two expressions, make sure that the arrays are conformable.  */
2760
2761 gfc_try
2762 gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
2763 {
2764   int op1_flag, op2_flag, d;
2765   mpz_t op1_size, op2_size;
2766   gfc_try t;
2767
2768   if (op1->rank == 0 || op2->rank == 0)
2769     return SUCCESS;
2770
2771   if (op1->rank != op2->rank)
2772     {
2773       gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid),
2774                  op1->rank, op2->rank, &op1->where);
2775       return FAILURE;
2776     }
2777
2778   t = SUCCESS;
2779
2780   for (d = 0; d < op1->rank; d++)
2781     {
2782       op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
2783       op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
2784
2785       if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
2786         {
2787           gfc_error ("Different shape for %s at %L on dimension %d "
2788                      "(%d and %d)", _(optype_msgid), &op1->where, d + 1,
2789                      (int) mpz_get_si (op1_size),
2790                      (int) mpz_get_si (op2_size));
2791
2792           t = FAILURE;
2793         }
2794
2795       if (op1_flag)
2796         mpz_clear (op1_size);
2797       if (op2_flag)
2798         mpz_clear (op2_size);
2799
2800       if (t == FAILURE)
2801         return FAILURE;
2802     }
2803
2804   return SUCCESS;
2805 }
2806
2807
2808 /* Given an assignable expression and an arbitrary expression, make
2809    sure that the assignment can take place.  */
2810
2811 gfc_try
2812 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
2813 {
2814   gfc_symbol *sym;
2815   gfc_ref *ref;
2816   int has_pointer;
2817
2818   sym = lvalue->symtree->n.sym;
2819
2820   /* Check INTENT(IN), unless the object itself is the component or
2821      sub-component of a pointer.  */
2822   has_pointer = sym->attr.pointer;
2823
2824   for (ref = lvalue->ref; ref; ref = ref->next)
2825     if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
2826       {
2827         has_pointer = 1;
2828         break;
2829       }
2830
2831   if (!has_pointer && sym->attr.intent == INTENT_IN)
2832     {
2833       gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2834                  sym->name, &lvalue->where);
2835       return FAILURE;
2836     }
2837
2838   /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2839      variable local to a function subprogram.  Its existence begins when
2840      execution of the function is initiated and ends when execution of the
2841      function is terminated...
2842      Therefore, the left hand side is no longer a variable, when it is:  */
2843   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
2844       && !sym->attr.external)
2845     {
2846       bool bad_proc;
2847       bad_proc = false;
2848
2849       /* (i) Use associated;  */
2850       if (sym->attr.use_assoc)
2851         bad_proc = true;
2852
2853       /* (ii) The assignment is in the main program; or  */
2854       if (gfc_current_ns->proc_name->attr.is_main_program)
2855         bad_proc = true;
2856
2857       /* (iii) A module or internal procedure...  */
2858       if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
2859            || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
2860           && gfc_current_ns->parent
2861           && (!(gfc_current_ns->parent->proc_name->attr.function
2862                 || gfc_current_ns->parent->proc_name->attr.subroutine)
2863               || gfc_current_ns->parent->proc_name->attr.is_main_program))
2864         {
2865           /* ... that is not a function...  */
2866           if (!gfc_current_ns->proc_name->attr.function)
2867             bad_proc = true;
2868
2869           /* ... or is not an entry and has a different name.  */
2870           if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
2871             bad_proc = true;
2872         }
2873
2874       /* (iv) Host associated and not the function symbol or the
2875               parent result.  This picks up sibling references, which
2876               cannot be entries.  */
2877       if (!sym->attr.entry
2878             && sym->ns == gfc_current_ns->parent
2879             && sym != gfc_current_ns->proc_name
2880             && sym != gfc_current_ns->parent->proc_name->result)
2881         bad_proc = true;
2882
2883       if (bad_proc)
2884         {
2885           gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
2886           return FAILURE;
2887         }
2888     }
2889
2890   if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
2891     {
2892       gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2893                  lvalue->rank, rvalue->rank, &lvalue->where);
2894       return FAILURE;
2895     }
2896
2897   if (lvalue->ts.type == BT_UNKNOWN)
2898     {
2899       gfc_error ("Variable type is UNKNOWN in assignment at %L",
2900                  &lvalue->where);
2901       return FAILURE;
2902     }
2903
2904   if (rvalue->expr_type == EXPR_NULL)
2905     {
2906       if (lvalue->symtree->n.sym->attr.pointer
2907           && lvalue->symtree->n.sym->attr.data)
2908         return SUCCESS;
2909       else
2910         {
2911           gfc_error ("NULL appears on right-hand side in assignment at %L",
2912                      &rvalue->where);
2913           return FAILURE;
2914         }
2915     }
2916
2917    if (sym->attr.cray_pointee
2918        && lvalue->ref != NULL
2919        && lvalue->ref->u.ar.type == AR_FULL
2920        && lvalue->ref->u.ar.as->cp_was_assumed)
2921      {
2922        gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2923                   "is illegal", &lvalue->where);
2924        return FAILURE;
2925      }
2926
2927   /* This is possibly a typo: x = f() instead of x => f().  */
2928   if (gfc_option.warn_surprising
2929       && rvalue->expr_type == EXPR_FUNCTION
2930       && rvalue->symtree->n.sym->attr.pointer)
2931     gfc_warning ("POINTER valued function appears on right-hand side of "
2932                  "assignment at %L", &rvalue->where);
2933
2934   /* Check size of array assignments.  */
2935   if (lvalue->rank != 0 && rvalue->rank != 0
2936       && gfc_check_conformance ("array assignment", lvalue, rvalue) != SUCCESS)
2937     return FAILURE;
2938
2939   if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
2940       && lvalue->symtree->n.sym->attr.data
2941       && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
2942                          "initialize non-integer variable '%s'",
2943                          &rvalue->where, lvalue->symtree->n.sym->name)
2944          == FAILURE)
2945     return FAILURE;
2946   else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
2947       && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
2948                          "a DATA statement and outside INT/REAL/DBLE/CMPLX",
2949                          &rvalue->where) == FAILURE)
2950     return FAILURE;
2951
2952   /* Handle the case of a BOZ literal on the RHS.  */
2953   if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
2954     {
2955       int rc;
2956       if (gfc_option.warn_surprising)
2957         gfc_warning ("BOZ literal at %L is bitwise transferred "
2958                      "non-integer symbol '%s'", &rvalue->where,
2959                      lvalue->symtree->n.sym->name);
2960       if (!gfc_convert_boz (rvalue, &lvalue->ts))
2961         return FAILURE;
2962       if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
2963         {
2964           if (rc == ARITH_UNDERFLOW)
2965             gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
2966                        ". This check can be disabled with the option "
2967                        "-fno-range-check", &rvalue->where);
2968           else if (rc == ARITH_OVERFLOW)
2969             gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
2970                        ". This check can be disabled with the option "
2971                        "-fno-range-check", &rvalue->where);
2972           else if (rc == ARITH_NAN)
2973             gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
2974                        ". This check can be disabled with the option "
2975                        "-fno-range-check", &rvalue->where);
2976           return FAILURE;
2977         }
2978     }
2979
2980   if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
2981     return SUCCESS;
2982
2983   /* Only DATA Statements come here.  */
2984   if (!conform)
2985     {
2986       /* Numeric can be converted to any other numeric. And Hollerith can be
2987          converted to any other type.  */
2988       if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
2989           || rvalue->ts.type == BT_HOLLERITH)
2990         return SUCCESS;
2991
2992       if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
2993         return SUCCESS;
2994
2995       gfc_error ("Incompatible types in DATA statement at %L; attempted "
2996                  "conversion of %s to %s", &lvalue->where,
2997                  gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
2998
2999       return FAILURE;
3000     }
3001
3002   /* Assignment is the only case where character variables of different
3003      kind values can be converted into one another.  */
3004   if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3005     {
3006       if (lvalue->ts.kind != rvalue->ts.kind)
3007         gfc_convert_chartype (rvalue, &lvalue->ts);
3008
3009       return SUCCESS;
3010     }
3011
3012   return gfc_convert_type (rvalue, &lvalue->ts, 1);
3013 }
3014
3015
3016 /* Check that a pointer assignment is OK.  We first check lvalue, and
3017    we only check rvalue if it's not an assignment to NULL() or a
3018    NULLIFY statement.  */
3019
3020 gfc_try
3021 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3022 {
3023   symbol_attribute attr;
3024   gfc_ref *ref;
3025   int is_pure;
3026   int pointer, check_intent_in;
3027
3028   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3029       && !lvalue->symtree->n.sym->attr.proc_pointer)
3030     {
3031       gfc_error ("Pointer assignment target is not a POINTER at %L",
3032                  &lvalue->where);
3033       return FAILURE;
3034     }
3035
3036   if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
3037       && lvalue->symtree->n.sym->attr.use_assoc)
3038     {
3039       gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3040                  "l-value since it is a procedure",
3041                  lvalue->symtree->n.sym->name, &lvalue->where);
3042       return FAILURE;
3043     }
3044
3045
3046   /* Check INTENT(IN), unless the object itself is the component or
3047      sub-component of a pointer.  */
3048   check_intent_in = 1;
3049   pointer = lvalue->symtree->n.sym->attr.pointer
3050               | lvalue->symtree->n.sym->attr.proc_pointer;
3051
3052   for (ref = lvalue->ref; ref; ref = ref->next)
3053     {
3054       if (pointer)
3055         check_intent_in = 0;
3056
3057       if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
3058         pointer = 1;
3059
3060       if (ref->type == REF_ARRAY && ref->next == NULL)
3061         {
3062           if (ref->u.ar.type == AR_FULL)
3063             break;
3064
3065           if (ref->u.ar.type != AR_SECTION)
3066             {
3067               gfc_error ("Expected bounds specification for '%s' at %L",
3068                          lvalue->symtree->n.sym->name, &lvalue->where);
3069               return FAILURE;
3070             }
3071
3072           if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3073                               "specification for '%s' in pointer assignment "
3074                               "at %L", lvalue->symtree->n.sym->name,
3075                               &lvalue->where) == FAILURE)
3076             return FAILURE;
3077
3078           gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3079                      "in gfortran", &lvalue->where);
3080           /* TODO: See PR 29785. Add checks that all lbounds are specified and
3081              either never or always the upper-bound; strides shall not be
3082              present.  */
3083           return FAILURE;
3084         }
3085     }
3086
3087   if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
3088     {
3089       gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3090                  lvalue->symtree->n.sym->name, &lvalue->where);
3091       return FAILURE;
3092     }
3093
3094   if (!pointer)
3095     {
3096       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
3097       return FAILURE;
3098     }
3099
3100   is_pure = gfc_pure (NULL);
3101
3102   if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
3103         && lvalue->symtree->n.sym->value != rvalue)
3104     {
3105       gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
3106       return FAILURE;
3107     }
3108
3109   /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3110      kind, etc for lvalue and rvalue must match, and rvalue must be a
3111      pure variable if we're in a pure function.  */
3112   if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3113     return SUCCESS;
3114
3115   /* TODO checks on rvalue for a procedure pointer assignment.  */
3116   if (lvalue->symtree->n.sym->attr.proc_pointer)
3117     return SUCCESS;
3118
3119   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3120     {
3121       gfc_error ("Different types in pointer assignment at %L; attempted "
3122                  "assignment of %s to %s", &lvalue->where,
3123                  gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3124       return FAILURE;
3125     }
3126
3127   if (lvalue->ts.kind != rvalue->ts.kind)
3128     {
3129       gfc_error ("Different kind type parameters in pointer "
3130                  "assignment at %L", &lvalue->where);
3131       return FAILURE;
3132     }
3133
3134   if (lvalue->rank != rvalue->rank)
3135     {
3136       gfc_error ("Different ranks in pointer assignment at %L",
3137                  &lvalue->where);
3138       return FAILURE;
3139     }
3140
3141   /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X).  */
3142   if (rvalue->expr_type == EXPR_NULL)
3143     return SUCCESS;
3144
3145   if (lvalue->ts.type == BT_CHARACTER
3146       && lvalue->ts.cl && rvalue->ts.cl
3147       && lvalue->ts.cl->length && rvalue->ts.cl->length
3148       && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
3149                                     rvalue->ts.cl->length)) == 1)
3150     {
3151       gfc_error ("Different character lengths in pointer "
3152                  "assignment at %L", &lvalue->where);
3153       return FAILURE;
3154     }
3155
3156   if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3157     lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3158
3159   attr = gfc_expr_attr (rvalue);
3160   if (!attr.target && !attr.pointer)
3161     {
3162       gfc_error ("Pointer assignment target is neither TARGET "
3163                  "nor POINTER at %L", &rvalue->where);
3164       return FAILURE;
3165     }
3166
3167   if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3168     {
3169       gfc_error ("Bad target in pointer assignment in PURE "
3170                  "procedure at %L", &rvalue->where);
3171     }
3172
3173   if (gfc_has_vector_index (rvalue))
3174     {
3175       gfc_error ("Pointer assignment with vector subscript "
3176                  "on rhs at %L", &rvalue->where);
3177       return FAILURE;
3178     }
3179
3180   if (attr.is_protected && attr.use_assoc
3181       && !(attr.pointer || attr.proc_pointer))
3182     {
3183       gfc_error ("Pointer assignment target has PROTECTED "
3184                  "attribute at %L", &rvalue->where);
3185       return FAILURE;
3186     }
3187
3188   return SUCCESS;
3189 }
3190
3191
3192 /* Relative of gfc_check_assign() except that the lvalue is a single
3193    symbol.  Used for initialization assignments.  */
3194
3195 gfc_try
3196 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3197 {
3198   gfc_expr lvalue;
3199   gfc_try r;
3200
3201   memset (&lvalue, '\0', sizeof (gfc_expr));
3202
3203   lvalue.expr_type = EXPR_VARIABLE;
3204   lvalue.ts = sym->ts;
3205   if (sym->as)
3206     lvalue.rank = sym->as->rank;
3207   lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3208   lvalue.symtree->n.sym = sym;
3209   lvalue.where = sym->declared_at;
3210
3211   if (sym->attr.pointer || sym->attr.proc_pointer)
3212     r = gfc_check_pointer_assign (&lvalue, rvalue);
3213   else
3214     r = gfc_check_assign (&lvalue, rvalue, 1);
3215
3216   gfc_free (lvalue.symtree);
3217
3218   return r;
3219 }
3220
3221
3222 /* Get an expression for a default initializer.  */
3223
3224 gfc_expr *
3225 gfc_default_initializer (gfc_typespec *ts)
3226 {
3227   gfc_constructor *tail;
3228   gfc_expr *init;
3229   gfc_component *c;
3230
3231   /* See if we have a default initializer.  */
3232   for (c = ts->derived->components; c; c = c->next)
3233     if (c->initializer || c->attr.allocatable)
3234       break;
3235
3236   if (!c)
3237     return NULL;
3238
3239   /* Build the constructor.  */
3240   init = gfc_get_expr ();
3241   init->expr_type = EXPR_STRUCTURE;
3242   init->ts = *ts;
3243   init->where = ts->derived->declared_at;
3244
3245   tail = NULL;
3246   for (c = ts->derived->components; c; c = c->next)
3247     {
3248       if (tail == NULL)
3249         init->value.constructor = tail = gfc_get_constructor ();
3250       else
3251         {
3252           tail->next = gfc_get_constructor ();
3253           tail = tail->next;
3254         }
3255
3256       if (c->initializer)
3257         tail->expr = gfc_copy_expr (c->initializer);
3258
3259       if (c->attr.allocatable)
3260         {
3261           tail->expr = gfc_get_expr ();
3262           tail->expr->expr_type = EXPR_NULL;
3263           tail->expr->ts = c->ts;
3264         }
3265     }
3266   return init;
3267 }
3268
3269
3270 /* Given a symbol, create an expression node with that symbol as a
3271    variable. If the symbol is array valued, setup a reference of the
3272    whole array.  */
3273
3274 gfc_expr *
3275 gfc_get_variable_expr (gfc_symtree *var)
3276 {
3277   gfc_expr *e;
3278
3279   e = gfc_get_expr ();
3280   e->expr_type = EXPR_VARIABLE;
3281   e->symtree = var;
3282   e->ts = var->n.sym->ts;
3283
3284   if (var->n.sym->as != NULL)
3285     {
3286       e->rank = var->n.sym->as->rank;
3287       e->ref = gfc_get_ref ();
3288       e->ref->type = REF_ARRAY;
3289       e->ref->u.ar.type = AR_FULL;
3290     }
3291
3292   return e;
3293 }
3294
3295
3296 /* General expression traversal function.  */
3297
3298 bool
3299 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3300                    bool (*func)(gfc_expr *, gfc_symbol *, int*),
3301                    int f)
3302 {
3303   gfc_array_ref ar;
3304   gfc_ref *ref;
3305   gfc_actual_arglist *args;
3306   gfc_constructor *c;
3307   int i;
3308
3309   if (!expr)
3310     return false;
3311
3312   if ((*func) (expr, sym, &f))
3313     return true;
3314
3315   if (expr->ts.type == BT_CHARACTER
3316         && expr->ts.cl
3317         && expr->ts.cl->length
3318         && expr->ts.cl->length->expr_type != EXPR_CONSTANT
3319         && gfc_traverse_expr (expr->ts.cl->length, sym, func, f))
3320     return true;
3321
3322   switch (expr->expr_type)
3323     {
3324     case EXPR_FUNCTION:
3325       for (args = expr->value.function.actual; args; args = args->next)
3326         {
3327           if (gfc_traverse_expr (args->expr, sym, func, f))
3328             return true;
3329         }
3330       break;
3331
3332     case EXPR_VARIABLE:
3333     case EXPR_CONSTANT:
3334     case EXPR_NULL:
3335     case EXPR_SUBSTRING:
3336       break;
3337
3338     case EXPR_STRUCTURE:
3339     case EXPR_ARRAY:
3340       for (c = expr->value.constructor; c; c = c->next)
3341         {
3342           if (gfc_traverse_expr (c->expr, sym, func, f))
3343             return true;
3344           if (c->iterator)
3345             {
3346               if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3347                 return true;
3348               if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3349                 return true;
3350               if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3351                 return true;
3352               if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3353                 return true;
3354             }
3355         }
3356       break;
3357
3358     case EXPR_OP:
3359       if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3360         return true;
3361       if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3362         return true;
3363       break;
3364
3365     default:
3366       gcc_unreachable ();
3367       break;
3368     }
3369
3370   ref = expr->ref;
3371   while (ref != NULL)
3372     {
3373       switch (ref->type)
3374         {
3375         case  REF_ARRAY:
3376           ar = ref->u.ar;
3377           for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3378             {
3379               if (gfc_traverse_expr (ar.start[i], sym, func, f))
3380                 return true;
3381               if (gfc_traverse_expr (ar.end[i], sym, func, f))
3382                 return true;
3383               if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3384                 return true;
3385             }
3386           break;
3387
3388         case REF_SUBSTRING:
3389           if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3390             return true;
3391           if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3392             return true;
3393           break;
3394
3395         case REF_COMPONENT:
3396           if (ref->u.c.component->ts.type == BT_CHARACTER
3397                 && ref->u.c.component->ts.cl
3398                 && ref->u.c.component->ts.cl->length
3399                 && ref->u.c.component->ts.cl->length->expr_type
3400                      != EXPR_CONSTANT
3401                 && gfc_traverse_expr (ref->u.c.component->ts.cl->length,
3402                                       sym, func, f))
3403             return true;
3404
3405           if (ref->u.c.component->as)
3406             for (i = 0; i < ref->u.c.component->as->rank; i++)
3407               {
3408                 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3409                                        sym, func, f))
3410                   return true;
3411                 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3412                                        sym, func, f))
3413                   return true;
3414               }
3415           break;
3416
3417         default:
3418           gcc_unreachable ();
3419         }
3420       ref = ref->next;
3421     }
3422   return false;
3423 }
3424
3425 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
3426
3427 static bool
3428 expr_set_symbols_referenced (gfc_expr *expr,
3429                              gfc_symbol *sym ATTRIBUTE_UNUSED,
3430                              int *f ATTRIBUTE_UNUSED)
3431 {
3432   if (expr->expr_type != EXPR_VARIABLE)
3433     return false;
3434   gfc_set_sym_referenced (expr->symtree->n.sym);
3435   return false;
3436 }
3437
3438 void
3439 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3440 {
3441   gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3442 }
3443
3444
3445 /* Walk an expression tree and check each variable encountered for being typed.
3446    If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3447    mode as is a basic arithmetic expression using those; this is for things in
3448    legacy-code like:
3449
3450      INTEGER :: arr(n), n
3451      INTEGER :: arr(n + 1), n
3452
3453    The namespace is needed for IMPLICIT typing.  */
3454
3455 static gfc_namespace* check_typed_ns;
3456
3457 static bool
3458 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3459                        int* f ATTRIBUTE_UNUSED)
3460 {
3461   gfc_try t;
3462
3463   if (e->expr_type != EXPR_VARIABLE)
3464     return false;
3465
3466   gcc_assert (e->symtree);
3467   t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
3468                               true, e->where);
3469
3470   return (t == FAILURE);
3471 }
3472
3473 gfc_try
3474 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
3475 {
3476   bool error_found;
3477
3478   /* If this is a top-level variable or EXPR_OP, do the check with strict given
3479      to us.  */
3480   if (!strict)
3481     {
3482       if (e->expr_type == EXPR_VARIABLE && !e->ref)
3483         return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
3484
3485       if (e->expr_type == EXPR_OP)
3486         {
3487           gfc_try t = SUCCESS;
3488
3489           gcc_assert (e->value.op.op1);
3490           t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
3491
3492           if (t == SUCCESS && e->value.op.op2)
3493             t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
3494
3495           return t;
3496         }
3497     }
3498
3499   /* Otherwise, walk the expression and do it strictly.  */
3500   check_typed_ns = ns;
3501   error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
3502
3503   return error_found ? FAILURE : SUCCESS;
3504 }
3505
3506 /* Walk an expression tree and replace all symbols with a corresponding symbol
3507    in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
3508    statements. The boolean return value is required by gfc_traverse_expr.  */
3509
3510 static bool
3511 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3512 {
3513   if ((expr->expr_type == EXPR_VARIABLE || expr->expr_type == EXPR_FUNCTION)
3514       && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
3515     {
3516       gfc_symtree *stree;
3517       gfc_get_sym_tree (expr->symtree->name, sym->formal_ns, &stree);
3518       stree->n.sym->attr = expr->symtree->n.sym->attr;
3519       expr->symtree = stree;
3520     }
3521   return false;
3522 }
3523
3524 void
3525 gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
3526 {
3527   gfc_traverse_expr (expr, dest, &replace_symbol, 0);
3528 }