gcc/fortran/data.c

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