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