gcc/fortran/expr.c

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