gcc/fortran/data.c

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