gcc/fortran/data.cc

   1 /* Supporting functions for resolving DATA statement.
   2    Copyright (C) 2002-2022 Free Software Foundation, Inc.
   3    Contributed by Lifang Zeng <zlf605@hotmail.com>
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21
  22 /* Notes for DATA statement implementation:
  23
  24    We first assign initial value to each symbol by gfc_assign_data_value
  25    during resolving DATA statement. Refer to check_data_variable and
  26    traverse_data_list in resolve.cc.
  27
  28    The complexity exists in the handling of array section, implied do
  29    and array of struct appeared in DATA statement.
  30
  31    We call gfc_conv_structure, gfc_con_array_array_initializer,
  32    etc., to convert the initial value. Refer to trans-expr.cc and
  33    trans-array.cc.  */
  34
  35 #include "config.h"
  36 #include "system.h"
  37 #include "coretypes.h"
  38 #include "gfortran.h"
  39 #include "data.h"
  40 #include "constructor.h"
  41
  42 static void formalize_init_expr (gfc_expr *);
  43
  44 /* Calculate the array element offset.  */
  45
  46 static void
  47 get_array_index (gfc_array_ref *ar, mpz_t *offset)
  48 {
  49   gfc_expr *e;
  50   int i;
  51   mpz_t delta;
  52   mpz_t tmp;
  53
  54   mpz_init (tmp);
  55   mpz_set_si (*offset, 0);
  56   mpz_init_set_si (delta, 1);
  57   for (i = 0; i < ar->dimen; i++)
  58     {
  59       e = gfc_copy_expr (ar->start[i]);
  60       gfc_simplify_expr (e, 1);
  61
  62       if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
  63           || (gfc_is_constant_expr (ar->as->upper[i]) == 0)
  64           || (gfc_is_constant_expr (e) == 0))
  65         gfc_error ("non-constant array in DATA statement %L", &ar->where);
  66
  67       mpz_set (tmp, e->value.integer);
  68       gfc_free_expr (e);
  69       mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
  70       mpz_mul (tmp, tmp, delta);
  71       mpz_add (*offset, tmp, *offset);
  72
  73       mpz_sub (tmp, ar->as->upper[i]->value.integer,
  74                ar->as->lower[i]->value.integer);
  75       mpz_add_ui (tmp, tmp, 1);
  76       mpz_mul (delta, tmp, delta);
  77     }
  78   mpz_clear (delta);
  79   mpz_clear (tmp);
  80 }
  81
  82 /* Find if there is a constructor which component is equal to COM.
  83    TODO: remove this, use symbol.cc(gfc_find_component) instead.  */
  84
  85 static gfc_constructor *
  86 find_con_by_component (gfc_component *com, gfc_constructor_base base)
  87 {
  88   gfc_constructor *c;
  89
  90   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
  91     if (com == c->n.component)
  92       return c;
  93
  94   return NULL;
  95 }
  96
  97
  98 /* Create a character type initialization expression from RVALUE.
  99    TS [and REF] describe [the substring of] the variable being initialized.
 100    INIT is the existing initializer, not NULL.  Initialization is performed
 101    according to normal assignment rules.  */
 102
 103 static gfc_expr *
 104 create_character_initializer (gfc_expr *init, gfc_typespec *ts,
 105                               gfc_ref *ref, gfc_expr *rvalue)
 106 {
 107   HOST_WIDE_INT len, start, end, tlen;
 108   gfc_char_t *dest;
 109   bool alloced_init = false;
 110
 111   if (init && init->ts.type != BT_CHARACTER)
 112     return NULL;
 113
 114   gfc_extract_hwi (ts->u.cl->length, &len);
 115
 116   if (init == NULL)
 117     {
 118       /* Create a new initializer.  */
 119       init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
 120       init->ts = *ts;
 121       alloced_init = true;
 122     }
 123
 124   dest = init->value.character.string;
 125
 126   if (ref)
 127     {
 128       gfc_expr *start_expr, *end_expr;
 129
 130       gcc_assert (ref->type == REF_SUBSTRING);
 131
 132       /* Only set a substring of the destination.  Fortran substring bounds
 133          are one-based [start, end], we want zero based [start, end).  */
 134       start_expr = gfc_copy_expr (ref->u.ss.start);
 135       end_expr = gfc_copy_expr (ref->u.ss.end);
 136
 137       if ((!gfc_simplify_expr(start_expr, 1))
 138           || !(gfc_simplify_expr(end_expr, 1)))
 139         {
 140           gfc_error ("failure to simplify substring reference in DATA "
 141                      "statement at %L", &ref->u.ss.start->where);
 142           gfc_free_expr (start_expr);
 143           gfc_free_expr (end_expr);
 144           if (alloced_init)
 145             gfc_free_expr (init);
 146           return NULL;
 147         }
 148
 149       gfc_extract_hwi (start_expr, &start);
 150       gfc_free_expr (start_expr);
 151       start--;
 152       gfc_extract_hwi (end_expr, &end);
 153       gfc_free_expr (end_expr);
 154     }
 155   else
 156     {
 157       /* Set the whole string.  */
 158       start = 0;
 159       end = len;
 160     }
 161
 162   /* Copy the initial value.  */
 163   if (rvalue->ts.type == BT_HOLLERITH)
 164     len = rvalue->representation.length - rvalue->ts.u.pad;
 165   else
 166     len = rvalue->value.character.length;
 167
 168   tlen = end - start;
 169   if (len > tlen)
 170     {
 171       if (tlen < 0)
 172         {
 173           gfc_warning_now (0, "Unused initialization string at %L because "
 174                            "variable has zero length", &rvalue->where);
 175           len = 0;
 176         }
 177       else
 178         {
 179           gfc_warning_now (0, "Initialization string at %L was truncated to "
 180                            "fit the variable (%ld/%ld)", &rvalue->where,
 181                            (long) tlen, (long) len);
 182           len = tlen;
 183         }
 184     }
 185
 186   if (start < 0)
 187     {
 188       gfc_error ("Substring start index at %L is less than one",
 189                  &ref->u.ss.start->where);
 190       return NULL;
 191     }
 192   if (end > init->value.character.length)
 193     {
 194       gfc_error ("Substring end index at %L exceeds the string length",
 195                  &ref->u.ss.end->where);
 196       return NULL;
 197     }
 198
 199   if (rvalue->ts.type == BT_HOLLERITH)
 200     {
 201       for (size_t i = 0; i < (size_t) len; i++)
 202         dest[start+i] = rvalue->representation.string[i];
 203     }
 204   else
 205     memcpy (&dest[start], rvalue->value.character.string,
 206             len * sizeof (gfc_char_t));
 207
 208   /* Pad with spaces.  Substrings will already be blanked.  */
 209   if (len < tlen && ref == NULL)
 210     gfc_wide_memset (&dest[start + len], ' ', end - (start + len));
 211
 212   if (rvalue->ts.type == BT_HOLLERITH)
 213     {
 214       init->representation.length = init->value.character.length;
 215       init->representation.string
 216         = gfc_widechar_to_char (init->value.character.string,
 217                                 init->value.character.length);
 218     }
 219
 220   return init;
 221 }
 222
 223
 224 /* Assign the initial value RVALUE to  LVALUE's symbol->value. If the
 225    LVALUE already has an initialization, we extend this, otherwise we
 226    create a new one.  If REPEAT is non-NULL, initialize *REPEAT
 227    consecutive values in LVALUE the same value in RVALUE.  In that case,
 228    LVALUE must refer to a full array, not an array section.  */
 229
 230 bool
 231 gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
 232                        mpz_t *repeat)
 233 {
 234   gfc_ref *ref;
 235   gfc_expr *init;
 236   gfc_expr *expr = NULL;
 237   gfc_expr *rexpr;
 238   gfc_constructor *con;
 239   gfc_constructor *last_con;
 240   gfc_symbol *symbol;
 241   gfc_typespec *last_ts;
 242   mpz_t offset;
 243   const char *msg = "F18(R841): data-implied-do object at %L is neither an "
 244                     "array-element nor a scalar-structure-component";
 245
 246   symbol = lvalue->symtree->n.sym;
 247   if (symbol->attr.flavor == FL_PARAMETER)
 248     {
 249       gfc_error ("PARAMETER %qs shall not appear in a DATA statement at %L",
 250                  symbol->name, &lvalue->where);
 251       return false;
 252     }
 253
 254   init = symbol->value;
 255   last_ts = &symbol->ts;
 256   last_con = NULL;
 257   mpz_init_set_si (offset, 0);
 258
 259   /* Find/create the parent expressions for subobject references.  */
 260   for (ref = lvalue->ref; ref; ref = ref->next)
 261     {
 262       /* Break out of the loop if we find a substring.  */
 263       if (ref->type == REF_SUBSTRING)
 264         {
 265           /* A substring should always be the last subobject reference.  */
 266           gcc_assert (ref->next == NULL);
 267           break;
 268         }
 269
 270       /* Use the existing initializer expression if it exists.  Otherwise
 271          create a new one.  */
 272       if (init == NULL)
 273         expr = gfc_get_expr ();
 274       else
 275         expr = init;
 276
 277       /* Find or create this element.  */
 278       switch (ref->type)
 279         {
 280         case REF_ARRAY:
 281           if (ref->u.ar.as->rank == 0)
 282             {
 283               gcc_assert (ref->u.ar.as->corank > 0);
 284               if (init == NULL)
 285                 free (expr);
 286               continue;
 287             }
 288
 289           if (init && expr->expr_type != EXPR_ARRAY)
 290             {
 291               gfc_error ("%qs at %L already is initialized at %L",
 292                          lvalue->symtree->n.sym->name, &lvalue->where,
 293                          &init->where);
 294               goto abort;
 295             }
 296
 297           if (init == NULL)
 298             {
 299               /* The element typespec will be the same as the array
 300                  typespec.  */
 301               expr->ts = *last_ts;
 302               /* Setup the expression to hold the constructor.  */
 303               expr->expr_type = EXPR_ARRAY;
 304               expr->rank = ref->u.ar.as->rank;
 305             }
 306
 307           if (ref->u.ar.type == AR_ELEMENT)
 308             get_array_index (&ref->u.ar, &offset);
 309           else
 310             mpz_set (offset, index);
 311
 312           /* Check the bounds.  */
 313           if (mpz_cmp_si (offset, 0) < 0)
 314             {
 315               gfc_error ("Data element below array lower bound at %L",
 316                          &lvalue->where);
 317               goto abort;
 318             }
 319           else if (repeat != NULL
 320                    && ref->u.ar.type != AR_ELEMENT)
 321             {
 322               mpz_t size, end;
 323               gcc_assert (ref->u.ar.type == AR_FULL
 324                           && ref->next == NULL);
 325               mpz_init_set (end, offset);
 326               mpz_add (end, end, *repeat);
 327               if (spec_size (ref->u.ar.as, &size))
 328                 {
 329                   if (mpz_cmp (end, size) > 0)
 330                     {
 331                       mpz_clear (size);
 332                       gfc_error ("Data element above array upper bound at %L",
 333                                  &lvalue->where);
 334                       goto abort;
 335                     }
 336                   mpz_clear (size);
 337                 }
 338
 339               con = gfc_constructor_lookup (expr->value.constructor,
 340                                             mpz_get_si (offset));
 341               if (!con)
 342                 {
 343                   con = gfc_constructor_lookup_next (expr->value.constructor,
 344                                                      mpz_get_si (offset));
 345                   if (con != NULL && mpz_cmp (con->offset, end) >= 0)
 346                     con = NULL;
 347                 }
 348
 349               /* Overwriting an existing initializer is non-standard but
 350                  usually only provokes a warning from other compilers.  */
 351               if (con != NULL && con->expr != NULL)
 352                 {
 353                   /* Order in which the expressions arrive here depends on
 354                      whether they are from data statements or F95 style
 355                      declarations.  Therefore, check which is the most
 356                      recent.  */
 357                   gfc_expr *exprd;
 358                   exprd = (LOCATION_LINE (con->expr->where.lb->location)
 359                            > LOCATION_LINE (rvalue->where.lb->location))
 360                           ? con->expr : rvalue;
 361                   if (gfc_notify_std (GFC_STD_GNU,
 362                                       "re-initialization of %qs at %L",
 363                                       symbol->name, &exprd->where) == false)
 364                     return false;
 365                 }
 366
 367               while (con != NULL)
 368                 {
 369                   gfc_constructor *next_con = gfc_constructor_next (con);
 370
 371                   if (mpz_cmp (con->offset, end) >= 0)
 372                     break;
 373                   if (mpz_cmp (con->offset, offset) < 0)
 374                     {
 375                       gcc_assert (mpz_cmp_si (con->repeat, 1) > 0);
 376                       mpz_sub (con->repeat, offset, con->offset);
 377                     }
 378                   else if (mpz_cmp_si (con->repeat, 1) > 0
 379                            && mpz_get_si (con->offset)
 380                               + mpz_get_si (con->repeat) > mpz_get_si (end))
 381                     {
 382                       int endi;
 383                       splay_tree_node node
 384                         = splay_tree_lookup (con->base,
 385                                              mpz_get_si (con->offset));
 386                       gcc_assert (node
 387                                   && con == (gfc_constructor *) node->value
 388                                   && node->key == (splay_tree_key)
 389                                                   mpz_get_si (con->offset));
 390                       endi = mpz_get_si (con->offset)
 391                              + mpz_get_si (con->repeat);
 392                       if (endi > mpz_get_si (end) + 1)
 393                         mpz_set_si (con->repeat, endi - mpz_get_si (end));
 394                       else
 395                         mpz_set_si (con->repeat, 1);
 396                       mpz_set (con->offset, end);
 397                       node->key = (splay_tree_key) mpz_get_si (end);
 398                       break;
 399                     }
 400                   else
 401                     gfc_constructor_remove (con);
 402                   con = next_con;
 403                 }
 404
 405               con = gfc_constructor_insert_expr (&expr->value.constructor,
 406                                                  NULL, &rvalue->where,
 407                                                  mpz_get_si (offset));
 408               mpz_set (con->repeat, *repeat);
 409               repeat = NULL;
 410               mpz_clear (end);
 411               break;
 412             }
 413           else
 414             {
 415               mpz_t size;
 416               if (spec_size (ref->u.ar.as, &size))
 417                 {
 418                   if (mpz_cmp (offset, size) >= 0)
 419                     {
 420                       mpz_clear (size);
 421                       gfc_error ("Data element above array upper bound at %L",
 422                                  &lvalue->where);
 423                       goto abort;
 424                     }
 425                   mpz_clear (size);
 426                 }
 427             }
 428
 429           con = gfc_constructor_lookup (expr->value.constructor,
 430                                         mpz_get_si (offset));
 431           if (!con)
 432             {
 433               con = gfc_constructor_insert_expr (&expr->value.constructor,
 434                                                  NULL, &rvalue->where,
 435                                                  mpz_get_si (offset));
 436             }
 437           else if (mpz_cmp_si (con->repeat, 1) > 0)
 438             {
 439               /* Need to split a range.  */
 440               if (mpz_cmp (con->offset, offset) < 0)
 441                 {
 442                   gfc_constructor *pred_con = con;
 443                   con = gfc_constructor_insert_expr (&expr->value.constructor,
 444                                                      NULL, &con->where,
 445                                                      mpz_get_si (offset));
 446                   con->expr = gfc_copy_expr (pred_con->expr);
 447                   mpz_add (con->repeat, pred_con->offset, pred_con->repeat);
 448                   mpz_sub (con->repeat, con->repeat, offset);
 449                   mpz_sub (pred_con->repeat, offset, pred_con->offset);
 450                 }
 451               if (mpz_cmp_si (con->repeat, 1) > 0)
 452                 {
 453                   gfc_constructor *succ_con;
 454                   succ_con
 455                     = gfc_constructor_insert_expr (&expr->value.constructor,
 456                                                    NULL, &con->where,
 457                                                    mpz_get_si (offset) + 1);
 458                   succ_con->expr = gfc_copy_expr (con->expr);
 459                   mpz_sub_ui (succ_con->repeat, con->repeat, 1);
 460                   mpz_set_si (con->repeat, 1);
 461                 }
 462             }
 463           break;
 464
 465         case REF_COMPONENT:
 466           if (init == NULL)
 467             {
 468               /* Setup the expression to hold the constructor.  */
 469               expr->expr_type = EXPR_STRUCTURE;
 470               expr->ts.type = BT_DERIVED;
 471               expr->ts.u.derived = ref->u.c.sym;
 472             }
 473           else
 474             gcc_assert (expr->expr_type == EXPR_STRUCTURE);
 475           last_ts = &ref->u.c.component->ts;
 476
 477           /* Find the same element in the existing constructor.  */
 478           con = find_con_by_component (ref->u.c.component,
 479                                        expr->value.constructor);
 480
 481           if (con == NULL)
 482             {
 483               /* Create a new constructor.  */
 484               con = gfc_constructor_append_expr (&expr->value.constructor,
 485                                                  NULL, NULL);
 486               con->n.component = ref->u.c.component;
 487             }
 488           break;
 489
 490         case REF_INQUIRY:
 491
 492           /* After some discussion on clf it was determined that the following
 493              violates F18(R841). If the error is removed, the expected result
 494              is obtained. Leaving the code in place ensures a clean error
 495              recovery.  */
 496           gfc_error (msg, &lvalue->where);
 497
 498           /* This breaks with the other reference types in that the output
 499              constructor has to be of type COMPLEX, whereas the lvalue is
 500              of type REAL.  The rvalue is copied to the real or imaginary
 501              part as appropriate.  In addition, for all except scalar
 502              complex variables, a complex expression has to provided, where
 503              the constructor does not have it, and the expression modified
 504              with a new value for the real or imaginary part.  */
 505           gcc_assert (ref->next == NULL && last_ts->type == BT_COMPLEX);
 506           rexpr = gfc_copy_expr (rvalue);
 507           if (!gfc_compare_types (&lvalue->ts, &rexpr->ts))
 508             gfc_convert_type (rexpr, &lvalue->ts, 0);
 509
 510           /* This is the scalar, complex case, where an initializer exists.  */
 511           if (init && ref == lvalue->ref)
 512             expr = symbol->value;
 513           /* Then all cases, where a complex expression does not exist.  */
 514           else if (!last_con || !last_con->expr)
 515             {
 516               expr = gfc_get_constant_expr (BT_COMPLEX, lvalue->ts.kind,
 517                                             &lvalue->where);
 518               if (last_con)
 519                 last_con->expr = expr;
 520             }
 521           else
 522             /* Finally, and existing constructor expression to be modified.  */
 523             expr = last_con->expr;
 524
 525           /* Rejection of LEN and KIND inquiry references is handled
 526              elsewhere. The error here is added as backup. The assertion
 527              of F2008 for RE and IM is also done elsewhere.  */
 528           switch (ref->u.i)
 529             {
 530             case INQUIRY_LEN:
 531             case INQUIRY_KIND:
 532               gfc_error ("LEN or KIND inquiry ref in DATA statement at %L",
 533                          &lvalue->where);
 534               goto abort;
 535             case INQUIRY_RE:
 536               mpfr_set (mpc_realref (expr->value.complex),
 537                         rexpr->value.real,
 538                         GFC_RND_MODE);
 539               break;
 540             case INQUIRY_IM:
 541               mpfr_set (mpc_imagref (expr->value.complex),
 542                         rexpr->value.real,
 543                         GFC_RND_MODE);
 544               break;
 545             }
 546
 547           /* Only the scalar, complex expression needs to be saved as the
 548              symbol value since the last constructor expression is already
 549              provided as the initializer in the code after the reference
 550              cases.  */
 551           if (ref == lvalue->ref)
 552             symbol->value = expr;
 553
 554           gfc_free_expr (rexpr);
 555           mpz_clear (offset);
 556           return true;
 557
 558         default:
 559           gcc_unreachable ();
 560         }
 561
 562       if (init == NULL)
 563         {
 564           /* Point the container at the new expression.  */
 565           if (last_con == NULL)
 566             symbol->value = expr;
 567           else
 568             last_con->expr = expr;
 569         }
 570       init = con->expr;
 571       last_con = con;
 572     }
 573
 574   mpz_clear (offset);
 575   gcc_assert (repeat == NULL);
 576
 577   /* Overwriting an existing initializer is non-standard but usually only
 578      provokes a warning from other compilers.  */
 579   if (init != NULL && init->where.lb && rvalue->where.lb)
 580     {
 581       /* Order in which the expressions arrive here depends on whether
 582          they are from data statements or F95 style declarations.
 583          Therefore, check which is the most recent.  */
 584       expr = (LOCATION_LINE (init->where.lb->location)
 585               > LOCATION_LINE (rvalue->where.lb->location))
 586            ? init : rvalue;
 587       if (gfc_notify_std (GFC_STD_GNU, "re-initialization of %qs at %L",
 588                           symbol->name, &expr->where) == false)
 589         return false;
 590     }
 591
 592   if (ref || (last_ts->type == BT_CHARACTER
 593               && rvalue->expr_type == EXPR_CONSTANT))
 594     {
 595       /* An initializer has to be constant.  */
 596       if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
 597         return false;
 598       if (lvalue->ts.u.cl->length
 599           && lvalue->ts.u.cl->length->expr_type != EXPR_CONSTANT)
 600         return false;
 601       expr = create_character_initializer (init, last_ts, ref, rvalue);
 602       if (!expr)
 603         return false;
 604     }
 605   else
 606     {
 607       if (lvalue->ts.type == BT_DERIVED
 608           && gfc_has_default_initializer (lvalue->ts.u.derived))
 609         {
 610           gfc_error ("Nonpointer object %qs with default initialization "
 611                      "shall not appear in a DATA statement at %L",
 612                      symbol->name, &lvalue->where);
 613           return false;
 614         }
 615
 616       expr = gfc_copy_expr (rvalue);
 617       if (!gfc_compare_types (&lvalue->ts, &expr->ts))
 618         gfc_convert_type (expr, &lvalue->ts, 0);
 619     }
 620
 621   if (last_con == NULL)
 622     symbol->value = expr;
 623   else
 624     last_con->expr = expr;
 625
 626   return true;
 627
 628 abort:
 629   if (!init)
 630     gfc_free_expr (expr);
 631   mpz_clear (offset);
 632   return false;
 633 }
 634
 635
 636 /* Modify the index of array section and re-calculate the array offset.  */
 637
 638 void
 639 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
 640                      mpz_t *offset_ret)
 641 {
 642   int i;
 643   mpz_t delta;
 644   mpz_t tmp;
 645   bool forwards;
 646   int cmp;
 647   gfc_expr *start, *end, *stride;
 648
 649   for (i = 0; i < ar->dimen; i++)
 650     {
 651       if (ar->dimen_type[i] != DIMEN_RANGE)
 652         continue;
 653
 654       if (ar->stride[i])
 655         {
 656           stride = gfc_copy_expr(ar->stride[i]);
 657           if(!gfc_simplify_expr(stride, 1))
 658             gfc_internal_error("Simplification error");
 659           mpz_add (section_index[i], section_index[i],
 660                    stride->value.integer);
 661           if (mpz_cmp_si (stride->value.integer, 0) >= 0)
 662             forwards = true;
 663           else
 664             forwards = false;
 665           gfc_free_expr(stride);
 666         }
 667       else
 668         {
 669           mpz_add_ui (section_index[i], section_index[i], 1);
 670           forwards = true;
 671         }
 672
 673       if (ar->end[i])
 674         {
 675           end = gfc_copy_expr(ar->end[i]);
 676           if(!gfc_simplify_expr(end, 1))
 677             gfc_internal_error("Simplification error");
 678           cmp = mpz_cmp (section_index[i], end->value.integer);
 679           gfc_free_expr(end);
 680         }
 681       else
 682         cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
 683
 684       if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
 685         {
 686           /* Reset index to start, then loop to advance the next index.  */
 687           if (ar->start[i])
 688             {
 689               start = gfc_copy_expr(ar->start[i]);
 690               if(!gfc_simplify_expr(start, 1))
 691                 gfc_internal_error("Simplification error");
 692               mpz_set (section_index[i], start->value.integer);
 693               gfc_free_expr(start);
 694             }
 695           else
 696             mpz_set (section_index[i], ar->as->lower[i]->value.integer);
 697         }
 698       else
 699         break;
 700     }
 701
 702   mpz_set_si (*offset_ret, 0);
 703   mpz_init_set_si (delta, 1);
 704   mpz_init (tmp);
 705   for (i = 0; i < ar->dimen; i++)
 706     {
 707       mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
 708       mpz_mul (tmp, tmp, delta);
 709       mpz_add (*offset_ret, tmp, *offset_ret);
 710
 711       mpz_sub (tmp, ar->as->upper[i]->value.integer,
 712                ar->as->lower[i]->value.integer);
 713       mpz_add_ui (tmp, tmp, 1);
 714       mpz_mul (delta, tmp, delta);
 715     }
 716   mpz_clear (tmp);
 717   mpz_clear (delta);
 718 }
 719
 720
 721 /* Rearrange a structure constructor so the elements are in the specified
 722    order.  Also insert NULL entries if necessary.  */
 723
 724 static void
 725 formalize_structure_cons (gfc_expr *expr)
 726 {
 727   gfc_constructor_base base = NULL;
 728   gfc_constructor *cur;
 729   gfc_component *order;
 730
 731   /* Constructor is already formalized.  */
 732   cur = gfc_constructor_first (expr->value.constructor);
 733   if (!cur || cur->n.component == NULL)
 734     return;
 735
 736   for (order = expr->ts.u.derived->components; order; order = order->next)
 737     {
 738       cur = find_con_by_component (order, expr->value.constructor);
 739       if (cur)
 740         gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
 741       else
 742         gfc_constructor_append_expr (&base, NULL, NULL);
 743     }
 744
 745   /* For all what it's worth, one would expect
 746        gfc_constructor_free (expr->value.constructor);
 747      here. However, if the constructor is actually free'd,
 748      hell breaks loose in the testsuite?!  */
 749
 750   expr->value.constructor = base;
 751 }
 752
 753
 754 /* Make sure an initialization expression is in normalized form, i.e., all
 755    elements of the constructors are in the correct order.  */
 756
 757 static void
 758 formalize_init_expr (gfc_expr *expr)
 759 {
 760   expr_t type;
 761   gfc_constructor *c;
 762
 763   if (expr == NULL)
 764     return;
 765
 766   type = expr->expr_type;
 767   switch (type)
 768     {
 769     case EXPR_ARRAY:
 770       for (c = gfc_constructor_first (expr->value.constructor);
 771            c; c = gfc_constructor_next (c))
 772         formalize_init_expr (c->expr);
 773
 774     break;
 775
 776     case EXPR_STRUCTURE:
 777       formalize_structure_cons (expr);
 778       break;
 779
 780     default:
 781       break;
 782     }
 783 }
 784
 785
 786 /* Resolve symbol's initial value after all data statement.  */
 787
 788 void
 789 gfc_formalize_init_value (gfc_symbol *sym)
 790 {
 791   formalize_init_expr (sym->value);
 792 }
 793
 794
 795 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
 796    offset.  */
 797
 798 void
 799 gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
 800 {
 801   int i;
 802   mpz_t delta;
 803   mpz_t tmp;
 804   gfc_expr *start;
 805
 806   mpz_set_si (*offset, 0);
 807   mpz_init (tmp);
 808   mpz_init_set_si (delta, 1);
 809   for (i = 0; i < ar->dimen; i++)
 810     {
 811       mpz_init (section_index[i]);
 812       switch (ar->dimen_type[i])
 813         {
 814         case DIMEN_ELEMENT:
 815         case DIMEN_RANGE:
 816           if (ar->start[i])
 817             {
 818               start = gfc_copy_expr(ar->start[i]);
 819               if(!gfc_simplify_expr(start, 1))
 820                 gfc_internal_error("Simplification error");
 821               mpz_sub (tmp, start->value.integer,
 822                        ar->as->lower[i]->value.integer);
 823               mpz_mul (tmp, tmp, delta);
 824               mpz_add (*offset, tmp, *offset);
 825               mpz_set (section_index[i], start->value.integer);
 826               gfc_free_expr(start);
 827             }
 828           else
 829               mpz_set (section_index[i], ar->as->lower[i]->value.integer);
 830           break;
 831
 832         case DIMEN_VECTOR:
 833           gfc_internal_error ("TODO: Vector sections in data statements");
 834
 835         default:
 836           gcc_unreachable ();
 837         }
 838
 839       mpz_sub (tmp, ar->as->upper[i]->value.integer,
 840                ar->as->lower[i]->value.integer);
 841       mpz_add_ui (tmp, tmp, 1);
 842       mpz_mul (delta, tmp, delta);
 843     }
 844
 845   mpz_clear (tmp);
 846   mpz_clear (delta);
 847 }
 848