gcc/fortran/data.c

   1 /* Supporting functions for resolving DATA statement.
   2    Copyright (C) 2002-2018 Free Software Foundation, Inc.
   3    Contributed by Lifang Zeng <zlf605@hotmail.com>
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21
  22 /* Notes for DATA statement implementation:
  23
  24    We first assign initial value to each symbol by gfc_assign_data_value
  25    during resolving DATA statement. Refer to check_data_variable and
  26    traverse_data_list in resolve.c.
  27
  28    The complexity exists in the handling of array section, implied do
  29    and array of struct appeared in DATA statement.
  30
  31    We call gfc_conv_structure, gfc_con_array_array_initializer,
  32    etc., to convert the initial value. Refer to trans-expr.c and
  33    trans-array.c.  */
  34
  35 #include "config.h"
  36 #include "system.h"
  37 #include "coretypes.h"
  38 #include "gfortran.h"
  39 #include "data.h"
  40 #include "constructor.h"
  41
  42 static void formalize_init_expr (gfc_expr *);
  43
  44 /* Calculate the array element offset.  */
  45
  46 static void
  47 get_array_index (gfc_array_ref *ar, mpz_t *offset)
  48 {
  49   gfc_expr *e;
  50   int i;
  51   mpz_t delta;
  52   mpz_t tmp;
  53
  54   mpz_init (tmp);
  55   mpz_set_si (*offset, 0);
  56   mpz_init_set_si (delta, 1);
  57   for (i = 0; i < ar->dimen; i++)
  58     {
  59       e = gfc_copy_expr (ar->start[i]);
  60       gfc_simplify_expr (e, 1);
  61
  62       if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
  63           || (gfc_is_constant_expr (ar->as->upper[i]) == 0)
  64           || (gfc_is_constant_expr (e) == 0))
  65         gfc_error ("non-constant array in DATA statement %L", &ar->where);
  66
  67       mpz_set (tmp, e->value.integer);
  68       gfc_free_expr (e);
  69       mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
  70       mpz_mul (tmp, tmp, delta);
  71       mpz_add (*offset, tmp, *offset);
  72
  73       mpz_sub (tmp, ar->as->upper[i]->value.integer,
  74                ar->as->lower[i]->value.integer);
  75       mpz_add_ui (tmp, tmp, 1);
  76       mpz_mul (delta, tmp, delta);
  77     }
  78   mpz_clear (delta);
  79   mpz_clear (tmp);
  80 }
  81
  82 /* Find if there is a constructor which component is equal to COM.
  83    TODO: remove this, use symbol.c(gfc_find_component) instead.  */
  84
  85 static gfc_constructor *
  86 find_con_by_component (gfc_component *com, gfc_constructor_base base)
  87 {
  88   gfc_constructor *c;
  89
  90   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
  91     if (com == c->n.component)
  92       return c;
  93
  94   return NULL;
  95 }
  96
  97
  98 /* Create a character type initialization expression from RVALUE.
  99    TS [and REF] describe [the substring of] the variable being initialized.
 100    INIT is the existing initializer, not NULL.  Initialization is performed
 101    according to normal assignment rules.  */
 102
 103 static gfc_expr *
 104 create_character_initializer (gfc_expr *init, gfc_typespec *ts,
 105                               gfc_ref *ref, gfc_expr *rvalue)
 106 {
 107   HOST_WIDE_INT len, start, end, tlen;
 108   gfc_char_t *dest;
 109   bool alloced_init = false;
 110
 111   if (init && init->ts.type != BT_CHARACTER)
 112     return NULL;
 113
 114   gfc_extract_hwi (ts->u.cl->length, &len);
 115
 116   if (init == NULL)
 117     {
 118       /* Create a new initializer.  */
 119       init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
 120       init->ts = *ts;
 121       alloced_init = true;
 122     }
 123
 124   dest = init->value.character.string;
 125
 126   if (ref)
 127     {
 128       gfc_expr *start_expr, *end_expr;
 129
 130       gcc_assert (ref->type == REF_SUBSTRING);
 131
 132       /* Only set a substring of the destination.  Fortran substring bounds
 133          are one-based [start, end], we want zero based [start, end).  */
 134       start_expr = gfc_copy_expr (ref->u.ss.start);
 135       end_expr = gfc_copy_expr (ref->u.ss.end);
 136
 137       if ((!gfc_simplify_expr(start_expr, 1))
 138           || !(gfc_simplify_expr(end_expr, 1)))
 139         {
 140           gfc_error ("failure to simplify substring reference in DATA "
 141                      "statement at %L", &ref->u.ss.start->where);
 142           gfc_free_expr (start_expr);
 143           gfc_free_expr (end_expr);
 144           if (alloced_init)
 145             gfc_free_expr (init);
 146           return NULL;
 147         }
 148
 149       gfc_extract_hwi (start_expr, &start);
 150       gfc_free_expr (start_expr);
 151       start--;
 152       gfc_extract_hwi (end_expr, &end);
 153       gfc_free_expr (end_expr);
 154     }
 155   else
 156     {
 157       /* Set the whole string.  */
 158       start = 0;
 159       end = len;
 160     }
 161
 162   /* Copy the initial value.  */
 163   if (rvalue->ts.type == BT_HOLLERITH)
 164     len = rvalue->representation.length - rvalue->ts.u.pad;
 165   else
 166     len = rvalue->value.character.length;
 167
 168   tlen = end - start;
 169   if (len > tlen)
 170     {
 171       if (tlen < 0)
 172         {
 173           gfc_warning_now (0, "Unused initialization string at %L because "
 174                            "variable has zero length", &rvalue->where);
 175           len = 0;
 176         }
 177       else
 178         {
 179           gfc_warning_now (0, "Initialization string at %L was truncated to "
 180                            "fit the variable (%ld/%ld)", &rvalue->where,
 181                            (long) tlen, (long) len);
 182           len = tlen;
 183         }
 184     }
 185
 186   if (rvalue->ts.type == BT_HOLLERITH)
 187     {
 188       for (size_t i = 0; i < (size_t) len; i++)
 189         dest[start+i] = rvalue->representation.string[i];
 190     }
 191   else
 192     memcpy (&dest[start], rvalue->value.character.string,
 193             len * sizeof (gfc_char_t));
 194
 195   /* Pad with spaces.  Substrings will already be blanked.  */
 196   if (len < tlen && ref == NULL)
 197     gfc_wide_memset (&dest[start + len], ' ', end - (start + len));
 198
 199   if (rvalue->ts.type == BT_HOLLERITH)
 200     {
 201       init->representation.length = init->value.character.length;
 202       init->representation.string
 203         = gfc_widechar_to_char (init->value.character.string,
 204                                 init->value.character.length);
 205     }
 206
 207   return init;
 208 }
 209
 210
 211 /* Assign the initial value RVALUE to  LVALUE's symbol->value. If the
 212    LVALUE already has an initialization, we extend this, otherwise we
 213    create a new one.  If REPEAT is non-NULL, initialize *REPEAT
 214    consecutive values in LVALUE the same value in RVALUE.  In that case,
 215    LVALUE must refer to a full array, not an array section.  */
 216
 217 bool
 218 gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
 219                        mpz_t *repeat)
 220 {
 221   gfc_ref *ref;
 222   gfc_expr *init;
 223   gfc_expr *expr = NULL;
 224   gfc_constructor *con;
 225   gfc_constructor *last_con;
 226   gfc_symbol *symbol;
 227   gfc_typespec *last_ts;
 228   mpz_t offset;
 229
 230   symbol = lvalue->symtree->n.sym;
 231   init = symbol->value;
 232   last_ts = &symbol->ts;
 233   last_con = NULL;
 234   mpz_init_set_si (offset, 0);
 235
 236   /* Find/create the parent expressions for subobject references.  */
 237   for (ref = lvalue->ref; ref; ref = ref->next)
 238     {
 239       /* Break out of the loop if we find a substring.  */
 240       if (ref->type == REF_SUBSTRING)
 241         {
 242           /* A substring should always be the last subobject reference.  */
 243           gcc_assert (ref->next == NULL);
 244           break;
 245         }
 246
 247       /* Use the existing initializer expression if it exists.  Otherwise
 248          create a new one.  */
 249       if (init == NULL)
 250         expr = gfc_get_expr ();
 251       else
 252         expr = init;
 253
 254       /* Find or create this element.  */
 255       switch (ref->type)
 256         {
 257         case REF_ARRAY:
 258           if (ref->u.ar.as->rank == 0)
 259             {
 260               gcc_assert (ref->u.ar.as->corank > 0);
 261               if (init == NULL)
 262                 free (expr);
 263               continue;
 264             }
 265
 266           if (init && expr->expr_type != EXPR_ARRAY)
 267             {
 268               gfc_error ("%qs at %L already is initialized at %L",
 269                          lvalue->symtree->n.sym->name, &lvalue->where,
 270                          &init->where);
 271               goto abort;
 272             }
 273
 274           if (init == NULL)
 275             {
 276               /* The element typespec will be the same as the array
 277                  typespec.  */
 278               expr->ts = *last_ts;
 279               /* Setup the expression to hold the constructor.  */
 280               expr->expr_type = EXPR_ARRAY;
 281               expr->rank = ref->u.ar.as->rank;
 282             }
 283
 284           if (ref->u.ar.type == AR_ELEMENT)
 285             get_array_index (&ref->u.ar, &offset);
 286           else
 287             mpz_set (offset, index);
 288
 289           /* Check the bounds.  */
 290           if (mpz_cmp_si (offset, 0) < 0)
 291             {
 292               gfc_error ("Data element below array lower bound at %L",
 293                          &lvalue->where);
 294               goto abort;
 295             }
 296           else if (repeat != NULL
 297                    && ref->u.ar.type != AR_ELEMENT)
 298             {
 299               mpz_t size, end;
 300               gcc_assert (ref->u.ar.type == AR_FULL
 301                           && ref->next == NULL);
 302               mpz_init_set (end, offset);
 303               mpz_add (end, end, *repeat);
 304               if (spec_size (ref->u.ar.as, &size))
 305                 {
 306                   if (mpz_cmp (end, size) > 0)
 307                     {
 308                       mpz_clear (size);
 309                       gfc_error ("Data element above array upper bound at %L",
 310                                  &lvalue->where);
 311                       goto abort;
 312                     }
 313                   mpz_clear (size);
 314                 }
 315
 316               con = gfc_constructor_lookup (expr->value.constructor,
 317                                             mpz_get_si (offset));
 318               if (!con)
 319                 {
 320                   con = gfc_constructor_lookup_next (expr->value.constructor,
 321                                                      mpz_get_si (offset));
 322                   if (con != NULL && mpz_cmp (con->offset, end) >= 0)
 323                     con = NULL;
 324                 }
 325
 326               /* Overwriting an existing initializer is non-standard but
 327                  usually only provokes a warning from other compilers.  */
 328               if (con != NULL && con->expr != NULL)
 329                 {
 330                   /* Order in which the expressions arrive here depends on
 331                      whether they are from data statements or F95 style
 332                      declarations.  Therefore, check which is the most
 333                      recent.  */
 334                   gfc_expr *exprd;
 335                   exprd = (LOCATION_LINE (con->expr->where.lb->location)
 336                            > LOCATION_LINE (rvalue->where.lb->location))
 337                           ? con->expr : rvalue;
 338                   if (gfc_notify_std (GFC_STD_GNU,
 339                                       "re-initialization of %qs at %L",
 340                                       symbol->name, &exprd->where) == false)
 341                     return false;
 342                 }
 343
 344               while (con != NULL)
 345                 {
 346                   gfc_constructor *next_con = gfc_constructor_next (con);
 347
 348                   if (mpz_cmp (con->offset, end) >= 0)
 349                     break;
 350                   if (mpz_cmp (con->offset, offset) < 0)
 351                     {
 352                       gcc_assert (mpz_cmp_si (con->repeat, 1) > 0);
 353                       mpz_sub (con->repeat, offset, con->offset);
 354                     }
 355                   else if (mpz_cmp_si (con->repeat, 1) > 0
 356                            && mpz_get_si (con->offset)
 357                               + mpz_get_si (con->repeat) > mpz_get_si (end))
 358                     {
 359                       int endi;
 360                       splay_tree_node node
 361                         = splay_tree_lookup (con->base,
 362                                              mpz_get_si (con->offset));
 363                       gcc_assert (node
 364                                   && con == (gfc_constructor *) node->value
 365                                   && node->key == (splay_tree_key)
 366                                                   mpz_get_si (con->offset));
 367                       endi = mpz_get_si (con->offset)
 368                              + mpz_get_si (con->repeat);
 369                       if (endi > mpz_get_si (end) + 1)
 370                         mpz_set_si (con->repeat, endi - mpz_get_si (end));
 371                       else
 372                         mpz_set_si (con->repeat, 1);
 373                       mpz_set (con->offset, end);
 374                       node->key = (splay_tree_key) mpz_get_si (end);
 375                       break;
 376                     }
 377                   else
 378                     gfc_constructor_remove (con);
 379                   con = next_con;
 380                 }
 381
 382               con = gfc_constructor_insert_expr (&expr->value.constructor,
 383                                                  NULL, &rvalue->where,
 384                                                  mpz_get_si (offset));
 385               mpz_set (con->repeat, *repeat);
 386               repeat = NULL;
 387               mpz_clear (end);
 388               break;
 389             }
 390           else
 391             {
 392               mpz_t size;
 393               if (spec_size (ref->u.ar.as, &size))
 394                 {
 395                   if (mpz_cmp (offset, size) >= 0)
 396                     {
 397                       mpz_clear (size);
 398                       gfc_error ("Data element above array upper bound at %L",
 399                                  &lvalue->where);
 400                       goto abort;
 401                     }
 402                   mpz_clear (size);
 403                 }
 404             }
 405
 406           con = gfc_constructor_lookup (expr->value.constructor,
 407                                         mpz_get_si (offset));
 408           if (!con)
 409             {
 410               con = gfc_constructor_insert_expr (&expr->value.constructor,
 411                                                  NULL, &rvalue->where,
 412                                                  mpz_get_si (offset));
 413             }
 414           else if (mpz_cmp_si (con->repeat, 1) > 0)
 415             {
 416               /* Need to split a range.  */
 417               if (mpz_cmp (con->offset, offset) < 0)
 418                 {
 419                   gfc_constructor *pred_con = con;
 420                   con = gfc_constructor_insert_expr (&expr->value.constructor,
 421                                                      NULL, &con->where,
 422                                                      mpz_get_si (offset));
 423                   con->expr = gfc_copy_expr (pred_con->expr);
 424                   mpz_add (con->repeat, pred_con->offset, pred_con->repeat);
 425                   mpz_sub (con->repeat, con->repeat, offset);
 426                   mpz_sub (pred_con->repeat, offset, pred_con->offset);
 427                 }
 428               if (mpz_cmp_si (con->repeat, 1) > 0)
 429                 {
 430                   gfc_constructor *succ_con;
 431                   succ_con
 432                     = gfc_constructor_insert_expr (&expr->value.constructor,
 433                                                    NULL, &con->where,
 434                                                    mpz_get_si (offset) + 1);
 435                   succ_con->expr = gfc_copy_expr (con->expr);
 436                   mpz_sub_ui (succ_con->repeat, con->repeat, 1);
 437                   mpz_set_si (con->repeat, 1);
 438                 }
 439             }
 440           break;
 441
 442         case REF_COMPONENT:
 443           if (init == NULL)
 444             {
 445               /* Setup the expression to hold the constructor.  */
 446               expr->expr_type = EXPR_STRUCTURE;
 447               expr->ts.type = BT_DERIVED;
 448               expr->ts.u.derived = ref->u.c.sym;
 449             }
 450           else
 451             gcc_assert (expr->expr_type == EXPR_STRUCTURE);
 452           last_ts = &ref->u.c.component->ts;
 453
 454           /* Find the same element in the existing constructor.  */
 455           con = find_con_by_component (ref->u.c.component,
 456                                        expr->value.constructor);
 457
 458           if (con == NULL)
 459             {
 460               /* Create a new constructor.  */
 461               con = gfc_constructor_append_expr (&expr->value.constructor,
 462                                                  NULL, NULL);
 463               con->n.component = ref->u.c.component;
 464             }
 465           break;
 466
 467         default:
 468           gcc_unreachable ();
 469         }
 470
 471       if (init == NULL)
 472         {
 473           /* Point the container at the new expression.  */
 474           if (last_con == NULL)
 475             symbol->value = expr;
 476           else
 477             last_con->expr = expr;
 478         }
 479       init = con->expr;
 480       last_con = con;
 481     }
 482
 483   mpz_clear (offset);
 484   gcc_assert (repeat == NULL);
 485
 486   /* Overwriting an existing initializer is non-standard but usually only
 487      provokes a warning from other compilers.  */
 488   if (init != NULL && init->where.lb && rvalue->where.lb)
 489     {
 490       /* Order in which the expressions arrive here depends on whether
 491          they are from data statements or F95 style declarations.
 492          Therefore, check which is the most recent.  */
 493       expr = (LOCATION_LINE (init->where.lb->location)
 494               > LOCATION_LINE (rvalue->where.lb->location))
 495            ? init : rvalue;
 496       if (gfc_notify_std (GFC_STD_GNU, "re-initialization of %qs at %L",
 497                           symbol->name, &expr->where) == false)
 498         return false;
 499     }
 500
 501   if (ref || last_ts->type == BT_CHARACTER)
 502     {
 503       /* An initializer has to be constant.  */
 504       if (rvalue->expr_type != EXPR_CONSTANT
 505           || (lvalue->ts.u.cl->length == NULL
 506               && !(ref && ref->u.ss.length != NULL)))
 507         return false;
 508       expr = create_character_initializer (init, last_ts, ref, rvalue);
 509     }
 510   else
 511     {
 512       if (lvalue->ts.type == BT_DERIVED
 513           && gfc_has_default_initializer (lvalue->ts.u.derived))
 514         {
 515           gfc_error ("Nonpointer object %qs with default initialization "
 516                      "shall not appear in a DATA statement at %L",
 517                      symbol->name, &lvalue->where);
 518           return false;
 519         }
 520
 521       expr = gfc_copy_expr (rvalue);
 522       if (!gfc_compare_types (&lvalue->ts, &expr->ts))
 523         gfc_convert_type (expr, &lvalue->ts, 0);
 524     }
 525
 526   if (last_con == NULL)
 527     symbol->value = expr;
 528   else
 529     last_con->expr = expr;
 530
 531   return true;
 532
 533 abort:
 534   if (!init)
 535     gfc_free_expr (expr);
 536   mpz_clear (offset);
 537   return false;
 538 }
 539
 540
 541 /* Modify the index of array section and re-calculate the array offset.  */
 542
 543 void
 544 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
 545                      mpz_t *offset_ret)
 546 {
 547   int i;
 548   mpz_t delta;
 549   mpz_t tmp;
 550   bool forwards;
 551   int cmp;
 552   gfc_expr *start, *end, *stride;
 553
 554   for (i = 0; i < ar->dimen; i++)
 555     {
 556       if (ar->dimen_type[i] != DIMEN_RANGE)
 557         continue;
 558
 559       if (ar->stride[i])
 560         {
 561           stride = gfc_copy_expr(ar->stride[i]);
 562           if(!gfc_simplify_expr(stride, 1))
 563             gfc_internal_error("Simplification error");
 564           mpz_add (section_index[i], section_index[i],
 565                    stride->value.integer);
 566           if (mpz_cmp_si (stride->value.integer, 0) >= 0)
 567             forwards = true;
 568           else
 569             forwards = false;
 570           gfc_free_expr(stride);
 571         }
 572       else
 573         {
 574           mpz_add_ui (section_index[i], section_index[i], 1);
 575           forwards = true;
 576         }
 577
 578       if (ar->end[i])
 579         {
 580           end = gfc_copy_expr(ar->end[i]);
 581           if(!gfc_simplify_expr(end, 1))
 582             gfc_internal_error("Simplification error");
 583           cmp = mpz_cmp (section_index[i], end->value.integer);
 584           gfc_free_expr(end);
 585         }
 586       else
 587         cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
 588
 589       if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
 590         {
 591           /* Reset index to start, then loop to advance the next index.  */
 592           if (ar->start[i])
 593             {
 594               start = gfc_copy_expr(ar->start[i]);
 595               if(!gfc_simplify_expr(start, 1))
 596                 gfc_internal_error("Simplification error");
 597               mpz_set (section_index[i], start->value.integer);
 598               gfc_free_expr(start);
 599             }
 600           else
 601             mpz_set (section_index[i], ar->as->lower[i]->value.integer);
 602         }
 603       else
 604         break;
 605     }
 606
 607   mpz_set_si (*offset_ret, 0);
 608   mpz_init_set_si (delta, 1);
 609   mpz_init (tmp);
 610   for (i = 0; i < ar->dimen; i++)
 611     {
 612       mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
 613       mpz_mul (tmp, tmp, delta);
 614       mpz_add (*offset_ret, tmp, *offset_ret);
 615
 616       mpz_sub (tmp, ar->as->upper[i]->value.integer,
 617                ar->as->lower[i]->value.integer);
 618       mpz_add_ui (tmp, tmp, 1);
 619       mpz_mul (delta, tmp, delta);
 620     }
 621   mpz_clear (tmp);
 622   mpz_clear (delta);
 623 }
 624
 625
 626 /* Rearrange a structure constructor so the elements are in the specified
 627    order.  Also insert NULL entries if necessary.  */
 628
 629 static void
 630 formalize_structure_cons (gfc_expr *expr)
 631 {
 632   gfc_constructor_base base = NULL;
 633   gfc_constructor *cur;
 634   gfc_component *order;
 635
 636   /* Constructor is already formalized.  */
 637   cur = gfc_constructor_first (expr->value.constructor);
 638   if (!cur || cur->n.component == NULL)
 639     return;
 640
 641   for (order = expr->ts.u.derived->components; order; order = order->next)
 642     {
 643       cur = find_con_by_component (order, expr->value.constructor);
 644       if (cur)
 645         gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
 646       else
 647         gfc_constructor_append_expr (&base, NULL, NULL);
 648     }
 649
 650   /* For all what it's worth, one would expect
 651        gfc_constructor_free (expr->value.constructor);
 652      here. However, if the constructor is actually free'd,
 653      hell breaks loose in the testsuite?!  */
 654
 655   expr->value.constructor = base;
 656 }
 657
 658
 659 /* Make sure an initialization expression is in normalized form, i.e., all
 660    elements of the constructors are in the correct order.  */
 661
 662 static void
 663 formalize_init_expr (gfc_expr *expr)
 664 {
 665   expr_t type;
 666   gfc_constructor *c;
 667
 668   if (expr == NULL)
 669     return;
 670
 671   type = expr->expr_type;
 672   switch (type)
 673     {
 674     case EXPR_ARRAY:
 675       for (c = gfc_constructor_first (expr->value.constructor);
 676            c; c = gfc_constructor_next (c))
 677         formalize_init_expr (c->expr);
 678
 679     break;
 680
 681     case EXPR_STRUCTURE:
 682       formalize_structure_cons (expr);
 683       break;
 684
 685     default:
 686       break;
 687     }
 688 }
 689
 690
 691 /* Resolve symbol's initial value after all data statement.  */
 692
 693 void
 694 gfc_formalize_init_value (gfc_symbol *sym)
 695 {
 696   formalize_init_expr (sym->value);
 697 }
 698
 699
 700 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
 701    offset.  */
 702
 703 void
 704 gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
 705 {
 706   int i;
 707   mpz_t delta;
 708   mpz_t tmp;
 709   gfc_expr *start;
 710
 711   mpz_set_si (*offset, 0);
 712   mpz_init (tmp);
 713   mpz_init_set_si (delta, 1);
 714   for (i = 0; i < ar->dimen; i++)
 715     {
 716       mpz_init (section_index[i]);
 717       switch (ar->dimen_type[i])
 718         {
 719         case DIMEN_ELEMENT:
 720         case DIMEN_RANGE:
 721           if (ar->start[i])
 722             {
 723               start = gfc_copy_expr(ar->start[i]);
 724               if(!gfc_simplify_expr(start, 1))
 725                 gfc_internal_error("Simplification error");
 726               mpz_sub (tmp, start->value.integer,
 727                        ar->as->lower[i]->value.integer);
 728               mpz_mul (tmp, tmp, delta);
 729               mpz_add (*offset, tmp, *offset);
 730               mpz_set (section_index[i], start->value.integer);
 731               gfc_free_expr(start);
 732             }
 733           else
 734               mpz_set (section_index[i], ar->as->lower[i]->value.integer);
 735           break;
 736
 737         case DIMEN_VECTOR:
 738           gfc_internal_error ("TODO: Vector sections in data statements");
 739
 740         default:
 741           gcc_unreachable ();
 742         }
 743
 744       mpz_sub (tmp, ar->as->upper[i]->value.integer,
 745                ar->as->lower[i]->value.integer);
 746       mpz_add_ui (tmp, tmp, 1);
 747       mpz_mul (delta, tmp, delta);
 748     }
 749
 750   mpz_clear (tmp);
 751   mpz_clear (delta);
 752 }
 753