gcc/fortran/data.c

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