gcc/fortran/data.c

   1 /* Supporting functions for resolving DATA statement.
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
   3    Free Software Foundation, Inc.
   4    Contributed by Lifang Zeng <zlf605@hotmail.com>
   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
  23 /* Notes for DATA statement implementation:
  24
  25    We first assign initial value to each symbol by gfc_assign_data_value
  26    during resolving DATA statement. Refer to check_data_variable and
  27    traverse_data_list in resolve.c.
  28
  29    The complexity exists in the handling of array section, implied do
  30    and array of struct appeared in DATA statement.
  31
  32    We call gfc_conv_structure, gfc_con_array_array_initializer,
  33    etc., to convert the initial value. Refer to trans-expr.c and
  34    trans-array.c.  */
  35
  36 #include "config.h"
  37 #include "gfortran.h"
  38 #include "data.h"
  39
  40 static void formalize_init_expr (gfc_expr *);
  41
  42 /* Calculate the array element offset.  */
  43
  44 static void
  45 get_array_index (gfc_array_ref *ar, mpz_t *offset)
  46 {
  47   gfc_expr *e;
  48   int i;
  49   mpz_t delta;
  50   mpz_t tmp;
  51
  52   mpz_init (tmp);
  53   mpz_set_si (*offset, 0);
  54   mpz_init_set_si (delta, 1);
  55   for (i = 0; i < ar->dimen; i++)
  56     {
  57       e = gfc_copy_expr (ar->start[i]);
  58       gfc_simplify_expr (e, 1);
  59
  60       if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
  61           || (gfc_is_constant_expr (ar->as->upper[i]) == 0)
  62           || (gfc_is_constant_expr (e) == 0))
  63         gfc_error ("non-constant array in DATA statement %L", &ar->where);
  64
  65       mpz_set (tmp, e->value.integer);
  66       mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
  67       mpz_mul (tmp, tmp, delta);
  68       mpz_add (*offset, tmp, *offset);
  69
  70       mpz_sub (tmp, ar->as->upper[i]->value.integer,
  71                ar->as->lower[i]->value.integer);
  72       mpz_add_ui (tmp, tmp, 1);
  73       mpz_mul (delta, tmp, delta);
  74     }
  75   mpz_clear (delta);
  76   mpz_clear (tmp);
  77 }
  78
  79
  80 /* Find if there is a constructor which offset is equal to OFFSET.  */
  81
  82 static gfc_constructor *
  83 find_con_by_offset (splay_tree spt, mpz_t offset)
  84 {
  85   mpz_t tmp;
  86   gfc_constructor *ret = NULL;
  87   gfc_constructor *con;
  88   splay_tree_node sptn;
  89
  90   /* The complexity is due to needing quick access to the linked list of
  91      constructors.  Both a linked list and a splay tree are used, and both
  92      are kept up to date if they are array elements (which is the only time
  93      that a specific constructor has to be found).  */
  94
  95   gcc_assert (spt != NULL);
  96   mpz_init (tmp);
  97
  98   sptn = splay_tree_lookup (spt, (splay_tree_key) mpz_get_si (offset));
  99
 100   if (sptn)
 101     ret = (gfc_constructor*) sptn->value;
 102   else
 103     {
 104        /* Need to check and see if we match a range, so we will pull
 105           the next lowest index and see if the range matches.  */
 106        sptn = splay_tree_predecessor (spt,
 107                                       (splay_tree_key) mpz_get_si (offset));
 108        if (sptn)
 109          {
 110             con = (gfc_constructor*) sptn->value;
 111             if (mpz_cmp_ui (con->repeat, 1) > 0)
 112               {
 113                  mpz_init (tmp);
 114                  mpz_add (tmp, con->n.offset, con->repeat);
 115                  if (mpz_cmp (offset, tmp) < 0)
 116                    ret = con;
 117                  mpz_clear (tmp);
 118               }
 119             else
 120               ret = NULL; /* The range did not match.  */
 121          }
 122       else
 123         ret = NULL; /* No pred, so no match.  */
 124     }
 125
 126   return ret;
 127 }
 128
 129
 130 /* Find if there is a constructor which component is equal to COM.  */
 131
 132 static gfc_constructor *
 133 find_con_by_component (gfc_component *com, gfc_constructor *con)
 134 {
 135   for (; con; con = con->next)
 136     {
 137       if (com == con->n.component)
 138         return con;
 139     }
 140   return NULL;
 141 }
 142
 143
 144 /* Create a character type initialization expression from RVALUE.
 145    TS [and REF] describe [the substring of] the variable being initialized.
 146    INIT is the existing initializer, not NULL.  Initialization is performed
 147    according to normal assignment rules.  */
 148
 149 static gfc_expr *
 150 create_character_intializer (gfc_expr *init, gfc_typespec *ts,
 151                              gfc_ref *ref, gfc_expr *rvalue)
 152 {
 153   int len, start, end;
 154   gfc_char_t *dest;
 155
 156   gfc_extract_int (ts->u.cl->length, &len);
 157
 158   if (init == NULL)
 159     {
 160       /* Create a new initializer.  */
 161       init = gfc_get_expr ();
 162       init->expr_type = EXPR_CONSTANT;
 163       init->ts = *ts;
 164
 165       dest = gfc_get_wide_string (len + 1);
 166       dest[len] = '\0';
 167       init->value.character.length = len;
 168       init->value.character.string = dest;
 169       /* Blank the string if we're only setting a substring.  */
 170       if (ref != NULL)
 171         gfc_wide_memset (dest, ' ', len);
 172     }
 173   else
 174     dest = init->value.character.string;
 175
 176   if (ref)
 177     {
 178       gfc_expr *start_expr, *end_expr;
 179
 180       gcc_assert (ref->type == REF_SUBSTRING);
 181
 182       /* Only set a substring of the destination.  Fortran substring bounds
 183          are one-based [start, end], we want zero based [start, end).  */
 184       start_expr = gfc_copy_expr (ref->u.ss.start);
 185       end_expr = gfc_copy_expr (ref->u.ss.end);
 186
 187       if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
 188           || (gfc_simplify_expr (end_expr, 1)) == FAILURE)
 189         {
 190           gfc_error ("failure to simplify substring reference in DATA "
 191                      "statement at %L", &ref->u.ss.start->where);
 192           return NULL;
 193         }
 194
 195       gfc_extract_int (start_expr, &start);
 196       start--;
 197       gfc_extract_int (end_expr, &end);
 198     }
 199   else
 200     {
 201       /* Set the whole string.  */
 202       start = 0;
 203       end = len;
 204     }
 205
 206   /* Copy the initial value.  */
 207   if (rvalue->ts.type == BT_HOLLERITH)
 208     len = rvalue->representation.length;
 209   else
 210     len = rvalue->value.character.length;
 211
 212   if (len > end - start)
 213     {
 214       len = end - start;
 215       gfc_warning_now ("initialization string truncated to match variable "
 216                        "at %L", &rvalue->where);
 217     }
 218
 219   if (rvalue->ts.type == BT_HOLLERITH)
 220     {
 221       int i;
 222       for (i = 0; i < len; i++)
 223         dest[start+i] = rvalue->representation.string[i];
 224     }
 225   else
 226     memcpy (&dest[start], rvalue->value.character.string,
 227             len * sizeof (gfc_char_t));
 228
 229   /* Pad with spaces.  Substrings will already be blanked.  */
 230   if (len < end - start && ref == NULL)
 231     gfc_wide_memset (&dest[start + len], ' ', end - (start + len));
 232
 233   if (rvalue->ts.type == BT_HOLLERITH)
 234     {
 235       init->representation.length = init->value.character.length;
 236       init->representation.string
 237         = gfc_widechar_to_char (init->value.character.string,
 238                                 init->value.character.length);
 239     }
 240
 241   return init;
 242 }
 243
 244
 245 /* Assign the initial value RVALUE to  LVALUE's symbol->value. If the
 246    LVALUE already has an initialization, we extend this, otherwise we
 247    create a new one.  */
 248
 249 gfc_try
 250 gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
 251 {
 252   gfc_ref *ref;
 253   gfc_expr *init;
 254   gfc_expr *expr;
 255   gfc_constructor *con;
 256   gfc_constructor *last_con;
 257   gfc_constructor *pred;
 258   gfc_symbol *symbol;
 259   gfc_typespec *last_ts;
 260   mpz_t offset;
 261   splay_tree spt;
 262   splay_tree_node sptn;
 263
 264   symbol = lvalue->symtree->n.sym;
 265   init = symbol->value;
 266   last_ts = &symbol->ts;
 267   last_con = NULL;
 268   mpz_init_set_si (offset, 0);
 269
 270   /* Find/create the parent expressions for subobject references.  */
 271   for (ref = lvalue->ref; ref; ref = ref->next)
 272     {
 273       /* Break out of the loop if we find a substring.  */
 274       if (ref->type == REF_SUBSTRING)
 275         {
 276           /* A substring should always be the last subobject reference.  */
 277           gcc_assert (ref->next == NULL);
 278           break;
 279         }
 280
 281       /* Use the existing initializer expression if it exists.  Otherwise
 282          create a new one.  */
 283       if (init == NULL)
 284         expr = gfc_get_expr ();
 285       else
 286         expr = init;
 287
 288       /* Find or create this element.  */
 289       switch (ref->type)
 290         {
 291         case REF_ARRAY:
 292           if (ref->u.ar.as->rank == 0)
 293             {
 294               gcc_assert (ref->u.ar.as->corank > 0);
 295               if (init == NULL)
 296                 gfc_free (expr);
 297               continue;
 298             }
 299
 300           if (init && expr->expr_type != EXPR_ARRAY)
 301             {
 302               gfc_error ("'%s' at %L already is initialized at %L",
 303                          lvalue->symtree->n.sym->name, &lvalue->where,
 304                          &init->where);
 305               return FAILURE;
 306             }
 307
 308           if (init == NULL)
 309             {
 310               /* The element typespec will be the same as the array
 311                  typespec.  */
 312               expr->ts = *last_ts;
 313               /* Setup the expression to hold the constructor.  */
 314               expr->expr_type = EXPR_ARRAY;
 315               expr->rank = ref->u.ar.as->rank;
 316             }
 317
 318           if (ref->u.ar.type == AR_ELEMENT)
 319             get_array_index (&ref->u.ar, &offset);
 320           else
 321             mpz_set (offset, index);
 322
 323           /* Check the bounds.  */
 324           if (mpz_cmp_si (offset, 0) < 0)
 325             {
 326               gfc_error ("Data element below array lower bound at %L",
 327                          &lvalue->where);
 328               return FAILURE;
 329             }
 330           else
 331             {
 332               mpz_t size;
 333               if (spec_size (ref->u.ar.as, &size) == SUCCESS)
 334                 {
 335                   if (mpz_cmp (offset, size) >= 0)
 336                   {
 337                     mpz_clear (size);
 338                     gfc_error ("Data element above array upper bound at %L",
 339                                &lvalue->where);
 340                     return FAILURE;
 341                   }
 342                   mpz_clear (size);
 343                 }
 344             }
 345
 346           /* Splay tree containing offset and gfc_constructor.  */
 347           spt = expr->con_by_offset;
 348
 349           if (spt == NULL)
 350             {
 351                spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL);
 352                expr->con_by_offset = spt;
 353                con = NULL;
 354             }
 355          else
 356           con = find_con_by_offset (spt, offset);
 357
 358           if (con == NULL)
 359             {
 360               splay_tree_key j;
 361
 362               /* Create a new constructor.  */
 363               con = gfc_get_constructor ();
 364               mpz_set (con->n.offset, offset);
 365               j = (splay_tree_key) mpz_get_si (offset);
 366               sptn = splay_tree_insert (spt, j, (splay_tree_value) con);
 367               /* Fix up the linked list.  */
 368               sptn = splay_tree_predecessor (spt, j);
 369               if (sptn == NULL)
 370                 {  /* Insert at the head.  */
 371                    con->next = expr->value.constructor;
 372                    expr->value.constructor = con;
 373                 }
 374               else
 375                 {  /* Insert in the chain.  */
 376                    pred = (gfc_constructor*) sptn->value;
 377                    con->next = pred->next;
 378                    pred->next = con;
 379                 }
 380             }
 381           break;
 382
 383         case REF_COMPONENT:
 384           if (init == NULL)
 385             {
 386               /* Setup the expression to hold the constructor.  */
 387               expr->expr_type = EXPR_STRUCTURE;
 388               expr->ts.type = BT_DERIVED;
 389               expr->ts.u.derived = ref->u.c.sym;
 390             }
 391           else
 392             gcc_assert (expr->expr_type == EXPR_STRUCTURE);
 393           last_ts = &ref->u.c.component->ts;
 394
 395           /* Find the same element in the existing constructor.  */
 396           con = expr->value.constructor;
 397           con = find_con_by_component (ref->u.c.component, con);
 398
 399           if (con == NULL)
 400             {
 401               /* Create a new constructor.  */
 402               con = gfc_get_constructor ();
 403               con->n.component = ref->u.c.component;
 404               con->next = expr->value.constructor;
 405               expr->value.constructor = con;
 406             }
 407           break;
 408
 409         default:
 410           gcc_unreachable ();
 411         }
 412
 413       if (init == NULL)
 414         {
 415           /* Point the container at the new expression.  */
 416           if (last_con == NULL)
 417             symbol->value = expr;
 418           else
 419             last_con->expr = expr;
 420         }
 421       init = con->expr;
 422       last_con = con;
 423     }
 424
 425   if (ref || last_ts->type == BT_CHARACTER)
 426     {
 427       if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
 428         return FAILURE;
 429       expr = create_character_intializer (init, last_ts, ref, rvalue);
 430     }
 431   else
 432     {
 433       /* Overwriting an existing initializer is non-standard but usually only
 434          provokes a warning from other compilers.  */
 435       if (init != NULL)
 436         {
 437           /* Order in which the expressions arrive here depends on whether
 438              they are from data statements or F95 style declarations.
 439              Therefore, check which is the most recent.  */
 440           expr = (LOCATION_LINE (init->where.lb->location)
 441                   > LOCATION_LINE (rvalue->where.lb->location))
 442                ? init : rvalue;
 443           gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization "
 444                           "of '%s' at %L", symbol->name, &expr->where);
 445         }
 446
 447       expr = gfc_copy_expr (rvalue);
 448       if (!gfc_compare_types (&lvalue->ts, &expr->ts))
 449         gfc_convert_type (expr, &lvalue->ts, 0);
 450     }
 451
 452   if (last_con == NULL)
 453     symbol->value = expr;
 454   else
 455     last_con->expr = expr;
 456
 457   return SUCCESS;
 458 }
 459
 460
 461 /* Similarly, but initialize REPEAT consecutive values in LVALUE the same
 462    value in RVALUE.  For the nonce, LVALUE must refer to a full array, not
 463    an array section.  */
 464
 465 void
 466 gfc_assign_data_value_range (gfc_expr *lvalue, gfc_expr *rvalue,
 467                              mpz_t index, mpz_t repeat)
 468 {
 469   gfc_ref *ref;
 470   gfc_expr *init, *expr;
 471   gfc_constructor *con, *last_con;
 472   gfc_constructor *pred;
 473   gfc_symbol *symbol;
 474   gfc_typespec *last_ts;
 475   mpz_t offset;
 476   splay_tree spt;
 477   splay_tree_node sptn;
 478
 479   symbol = lvalue->symtree->n.sym;
 480   init = symbol->value;
 481   last_ts = &symbol->ts;
 482   last_con = NULL;
 483   mpz_init_set_si (offset, 0);
 484
 485   /* Find/create the parent expressions for subobject references.  */
 486   for (ref = lvalue->ref; ref; ref = ref->next)
 487     {
 488       /* Use the existing initializer expression if it exists.
 489          Otherwise create a new one.  */
 490       if (init == NULL)
 491         expr = gfc_get_expr ();
 492       else
 493         expr = init;
 494
 495       /* Find or create this element.  */
 496       switch (ref->type)
 497         {
 498         case REF_ARRAY:
 499           if (init == NULL)
 500             {
 501               /* The element typespec will be the same as the array
 502                  typespec.  */
 503               expr->ts = *last_ts;
 504               /* Setup the expression to hold the constructor.  */
 505               expr->expr_type = EXPR_ARRAY;
 506               expr->rank = ref->u.ar.as->rank;
 507             }
 508           else
 509             gcc_assert (expr->expr_type == EXPR_ARRAY);
 510
 511           if (ref->u.ar.type == AR_ELEMENT)
 512             {
 513               get_array_index (&ref->u.ar, &offset);
 514
 515               /* This had better not be the bottom of the reference.
 516                  We can still get to a full array via a component.  */
 517               gcc_assert (ref->next != NULL);
 518             }
 519           else
 520             {
 521               mpz_set (offset, index);
 522
 523               /* We're at a full array or an array section.  This means
 524                  that we've better have found a full array, and that we're
 525                  at the bottom of the reference.  */
 526               gcc_assert (ref->u.ar.type == AR_FULL);
 527               gcc_assert (ref->next == NULL);
 528             }
 529
 530           /* Find the same element in the existing constructor.  */
 531
 532           /* Splay tree containing offset and gfc_constructor.  */
 533           spt = expr->con_by_offset;
 534
 535           if (spt == NULL)
 536             {
 537                spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL);
 538                expr->con_by_offset = spt;
 539                con = NULL;
 540             }
 541           else
 542             con = find_con_by_offset (spt, offset);
 543
 544           if (con == NULL)
 545             {
 546               splay_tree_key j;
 547               /* Create a new constructor.  */
 548               con = gfc_get_constructor ();
 549               mpz_set (con->n.offset, offset);
 550               j = (splay_tree_key) mpz_get_si (offset);
 551
 552               if (ref->next == NULL)
 553                 mpz_set (con->repeat, repeat);
 554               sptn = splay_tree_insert (spt, j, (splay_tree_value) con);
 555               /* Fix up the linked list.  */
 556               sptn = splay_tree_predecessor (spt, j);
 557               if (sptn == NULL)
 558                 {  /* Insert at the head.  */
 559                    con->next = expr->value.constructor;
 560                    expr->value.constructor = con;
 561                 }
 562               else
 563                 {  /* Insert in the chain.  */
 564                    pred = (gfc_constructor*) sptn->value;
 565                    con->next = pred->next;
 566                    pred->next = con;
 567                 }
 568             }
 569           else
 570             gcc_assert (ref->next != NULL);
 571           break;
 572
 573         case REF_COMPONENT:
 574           if (init == NULL)
 575             {
 576               /* Setup the expression to hold the constructor.  */
 577               expr->expr_type = EXPR_STRUCTURE;
 578               expr->ts.type = BT_DERIVED;
 579               expr->ts.u.derived = ref->u.c.sym;
 580             }
 581           else
 582             gcc_assert (expr->expr_type == EXPR_STRUCTURE);
 583           last_ts = &ref->u.c.component->ts;
 584
 585           /* Find the same element in the existing constructor.  */
 586           con = expr->value.constructor;
 587           con = find_con_by_component (ref->u.c.component, con);
 588
 589           if (con == NULL)
 590             {
 591               /* Create a new constructor.  */
 592               con = gfc_get_constructor ();
 593               con->n.component = ref->u.c.component;
 594               con->next = expr->value.constructor;
 595               expr->value.constructor = con;
 596             }
 597
 598           /* Since we're only intending to initialize arrays here,
 599              there better be an inner reference.  */
 600           gcc_assert (ref->next != NULL);
 601           break;
 602
 603         case REF_SUBSTRING:
 604         default:
 605           gcc_unreachable ();
 606         }
 607
 608       if (init == NULL)
 609         {
 610           /* Point the container at the new expression.  */
 611           if (last_con == NULL)
 612             symbol->value = expr;
 613           else
 614             last_con->expr = expr;
 615         }
 616       init = con->expr;
 617       last_con = con;
 618     }
 619
 620   if (last_ts->type == BT_CHARACTER)
 621     expr = create_character_intializer (init, last_ts, NULL, rvalue);
 622   else
 623     {
 624       /* We should never be overwriting an existing initializer.  */
 625       gcc_assert (!init);
 626
 627       expr = gfc_copy_expr (rvalue);
 628       if (!gfc_compare_types (&lvalue->ts, &expr->ts))
 629         gfc_convert_type (expr, &lvalue->ts, 0);
 630     }
 631
 632   if (last_con == NULL)
 633     symbol->value = expr;
 634   else
 635     last_con->expr = expr;
 636 }
 637
 638 /* Modify the index of array section and re-calculate the array offset.  */
 639
 640 void
 641 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
 642                      mpz_t *offset_ret)
 643 {
 644   int i;
 645   mpz_t delta;
 646   mpz_t tmp;
 647   bool forwards;
 648   int cmp;
 649
 650   for (i = 0; i < ar->dimen; i++)
 651     {
 652       if (ar->dimen_type[i] != DIMEN_RANGE)
 653         continue;
 654
 655       if (ar->stride[i])
 656         {
 657           mpz_add (section_index[i], section_index[i],
 658                    ar->stride[i]->value.integer);
 659         if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
 660           forwards = true;
 661         else
 662           forwards = false;
 663         }
 664       else
 665         {
 666           mpz_add_ui (section_index[i], section_index[i], 1);
 667           forwards = true;
 668         }
 669
 670       if (ar->end[i])
 671         cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
 672       else
 673         cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
 674
 675       if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
 676         {
 677           /* Reset index to start, then loop to advance the next index.  */
 678           if (ar->start[i])
 679             mpz_set (section_index[i], ar->start[i]->value.integer);
 680           else
 681             mpz_set (section_index[i], ar->as->lower[i]->value.integer);
 682         }
 683       else
 684         break;
 685     }
 686
 687   mpz_set_si (*offset_ret, 0);
 688   mpz_init_set_si (delta, 1);
 689   mpz_init (tmp);
 690   for (i = 0; i < ar->dimen; i++)
 691     {
 692       mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
 693       mpz_mul (tmp, tmp, delta);
 694       mpz_add (*offset_ret, tmp, *offset_ret);
 695
 696       mpz_sub (tmp, ar->as->upper[i]->value.integer,
 697                ar->as->lower[i]->value.integer);
 698       mpz_add_ui (tmp, tmp, 1);
 699       mpz_mul (delta, tmp, delta);
 700     }
 701   mpz_clear (tmp);
 702   mpz_clear (delta);
 703 }
 704
 705
 706 /* Rearrange a structure constructor so the elements are in the specified
 707    order.  Also insert NULL entries if necessary.  */
 708
 709 static void
 710 formalize_structure_cons (gfc_expr *expr)
 711 {
 712   gfc_constructor *head;
 713   gfc_constructor *tail;
 714   gfc_constructor *cur;
 715   gfc_constructor *last;
 716   gfc_constructor *c;
 717   gfc_component *order;
 718
 719   c = expr->value.constructor;
 720
 721   /* Constructor is already formalized.  */
 722   if (!c || c->n.component == NULL)
 723     return;
 724
 725   head = tail = NULL;
 726   for (order = expr->ts.u.derived->components; order; order = order->next)
 727     {
 728       /* Find the next component.  */
 729       last = NULL;
 730       cur = c;
 731       while (cur != NULL && cur->n.component != order)
 732         {
 733           last = cur;
 734           cur = cur->next;
 735         }
 736
 737       if (cur == NULL)
 738         {
 739           /* Create a new one.  */
 740           cur = gfc_get_constructor ();
 741         }
 742       else
 743         {
 744           /* Remove it from the chain.  */
 745           if (last == NULL)
 746             c = cur->next;
 747           else
 748             last->next = cur->next;
 749           cur->next = NULL;
 750
 751           formalize_init_expr (cur->expr);
 752         }
 753
 754       /* Add it to the new constructor.  */
 755       if (head == NULL)
 756         head = tail = cur;
 757       else
 758         {
 759           tail->next = cur;
 760           tail = tail->next;
 761         }
 762     }
 763   gcc_assert (c == NULL);
 764   expr->value.constructor = head;
 765 }
 766
 767
 768 /* Make sure an initialization expression is in normalized form, i.e., all
 769    elements of the constructors are in the correct order.  */
 770
 771 static void
 772 formalize_init_expr (gfc_expr *expr)
 773 {
 774   expr_t type;
 775   gfc_constructor *c;
 776
 777   if (expr == NULL)
 778     return;
 779
 780   type = expr->expr_type;
 781   switch (type)
 782     {
 783     case EXPR_ARRAY:
 784       c = expr->value.constructor;
 785       while (c)
 786         {
 787           formalize_init_expr (c->expr);
 788           c = c->next;
 789         }
 790       break;
 791
 792     case EXPR_STRUCTURE:
 793       formalize_structure_cons (expr);
 794       break;
 795
 796     default:
 797       break;
 798     }
 799 }
 800
 801
 802 /* Resolve symbol's initial value after all data statement.  */
 803
 804 void
 805 gfc_formalize_init_value (gfc_symbol *sym)
 806 {
 807   formalize_init_expr (sym->value);
 808 }
 809
 810
 811 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
 812    offset.  */
 813
 814 void
 815 gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
 816 {
 817   int i;
 818   mpz_t delta;
 819   mpz_t tmp;
 820
 821   mpz_set_si (*offset, 0);
 822   mpz_init (tmp);
 823   mpz_init_set_si (delta, 1);
 824   for (i = 0; i < ar->dimen; i++)
 825     {
 826       mpz_init (section_index[i]);
 827       switch (ar->dimen_type[i])
 828         {
 829         case DIMEN_ELEMENT:
 830         case DIMEN_RANGE:
 831           if (ar->start[i])
 832             {
 833               mpz_sub (tmp, ar->start[i]->value.integer,
 834                        ar->as->lower[i]->value.integer);
 835               mpz_mul (tmp, tmp, delta);
 836               mpz_add (*offset, tmp, *offset);
 837               mpz_set (section_index[i], ar->start[i]->value.integer);
 838             }
 839           else
 840               mpz_set (section_index[i], ar->as->lower[i]->value.integer);
 841           break;
 842
 843         case DIMEN_VECTOR:
 844           gfc_internal_error ("TODO: Vector sections in data statements");
 845
 846         default:
 847           gcc_unreachable ();
 848         }
 849
 850       mpz_sub (tmp, ar->as->upper[i]->value.integer,
 851                ar->as->lower[i]->value.integer);
 852       mpz_add_ui (tmp, tmp, 1);
 853       mpz_mul (delta, tmp, delta);
 854     }
 855
 856   mpz_clear (tmp);
 857   mpz_clear (delta);
 858 }
 859