gcc/fortran/data.c

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