gcc/fortran/data.c

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