gcc/fortran/data.c

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