gcc/fortran/expr.c

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