gcc/fortran/data.c

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