gcc/fortran/data.c

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