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     len = end - start;
 189   memcpy (&dest[start], rvalue->value.character.string, len);
 190
 191   /* Pad with spaces.  Substrings will already be blanked.  */
 192   if (len < end - start && ref == NULL)
 193     memset (&dest[start + len], ' ', end - (start + len));
 194
 195   return init;
 196 }
 197
 198 /* Assign the initial value RVALUE to  LVALUE's symbol->value. If the
 199    LVALUE already has an initialization, we extend this, otherwise we
 200    create a new one.  */
 201
 202 void
 203 gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
 204 {
 205   gfc_ref *ref;
 206   gfc_expr *init;
 207   gfc_expr *expr;
 208   gfc_constructor *con;
 209   gfc_constructor *last_con;
 210   gfc_symbol *symbol;
 211   gfc_typespec *last_ts;
 212   mpz_t offset;
 213
 214   symbol = lvalue->symtree->n.sym;
 215   init = symbol->value;
 216   last_ts = &symbol->ts;
 217   last_con = NULL;
 218   mpz_init_set_si (offset, 0);
 219
 220   /* Find/create the parent expressions for subobject references.  */
 221   for (ref = lvalue->ref; ref; ref = ref->next)
 222     {
 223       /* Break out of the loop if we find a substring.  */
 224       if (ref->type == REF_SUBSTRING)
 225         {
 226           /* A substring should always br the last subobject reference.  */
 227           gcc_assert (ref->next == NULL);
 228           break;
 229         }
 230
 231       /* Use the existing initializer expression if it exists.  Otherwise
 232          create a new one.  */
 233       if (init == NULL)
 234         expr = gfc_get_expr ();
 235       else
 236         expr = init;
 237
 238       /* Find or create this element.  */
 239       switch (ref->type)
 240         {
 241         case REF_ARRAY:
 242           if (init == NULL)
 243             {
 244               /* The element typespec will be the same as the array
 245                  typespec.  */
 246               expr->ts = *last_ts;
 247               /* Setup the expression to hold the constructor.  */
 248               expr->expr_type = EXPR_ARRAY;
 249               expr->rank = ref->u.ar.as->rank;
 250             }
 251           else
 252             gcc_assert (expr->expr_type == EXPR_ARRAY);
 253
 254           if (ref->u.ar.type == AR_ELEMENT)
 255             get_array_index (&ref->u.ar, &offset);
 256           else
 257             mpz_set (offset, index);
 258
 259           /* Find the same element in the existing constructor.  */
 260           con = expr->value.constructor;
 261           con = find_con_by_offset (offset, con);
 262
 263           if (con == NULL)
 264             {
 265               /* Create a new constructor.  */
 266               con = gfc_get_constructor ();
 267               mpz_set (con->n.offset, offset);
 268               gfc_insert_constructor (expr, con);
 269             }
 270           break;
 271
 272         case REF_COMPONENT:
 273           if (init == NULL)
 274             {
 275               /* Setup the expression to hold the constructor.  */
 276               expr->expr_type = EXPR_STRUCTURE;
 277               expr->ts.type = BT_DERIVED;
 278               expr->ts.derived = ref->u.c.sym;
 279             }
 280           else
 281             gcc_assert (expr->expr_type == EXPR_STRUCTURE);
 282           last_ts = &ref->u.c.component->ts;
 283
 284           /* Find the same element in the existing constructor.  */
 285           con = expr->value.constructor;
 286           con = find_con_by_component (ref->u.c.component, con);
 287
 288           if (con == NULL)
 289             {
 290               /* Create a new constructor.  */
 291               con = gfc_get_constructor ();
 292               con->n.component = ref->u.c.component;
 293               con->next = expr->value.constructor;
 294               expr->value.constructor = con;
 295             }
 296           break;
 297
 298         default:
 299           gcc_unreachable ();
 300         }
 301
 302       if (init == NULL)
 303         {
 304           /* Point the container at the new expression.  */
 305           if (last_con == NULL)
 306             symbol->value = expr;
 307           else
 308             last_con->expr = expr;
 309         }
 310       init = con->expr;
 311       last_con = con;
 312     }
 313
 314   if (ref || last_ts->type == BT_CHARACTER)
 315     expr = create_character_intializer (init, last_ts, ref, rvalue);
 316   else
 317     {
 318       /* We should never be overwriting an existing initializer.  */
 319       gcc_assert (!init);
 320
 321       expr = gfc_copy_expr (rvalue);
 322       if (!gfc_compare_types (&lvalue->ts, &expr->ts))
 323         gfc_convert_type (expr, &lvalue->ts, 0);
 324     }
 325
 326   if (last_con == NULL)
 327     symbol->value = expr;
 328   else
 329     last_con->expr = expr;
 330 }
 331
 332 /* Similarly, but initialize REPEAT consecutive values in LVALUE the same
 333    value in RVALUE.  For the nonce, LVALUE must refer to a full array, not
 334    an array section.  */
 335
 336 void
 337 gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue,
 338                              mpz_t index, mpz_t repeat)
 339 {
 340   gfc_ref *ref;
 341   gfc_expr *init, *expr;
 342   gfc_constructor *con, *last_con;
 343   gfc_symbol *symbol;
 344   gfc_typespec *last_ts;
 345   mpz_t offset;
 346
 347   symbol = lvalue->symtree->n.sym;
 348   init = symbol->value;
 349   last_ts = &symbol->ts;
 350   last_con = NULL;
 351   mpz_init_set_si (offset, 0);
 352
 353   /* Find/create the parent expressions for subobject references.  */
 354   for (ref = lvalue->ref; ref; ref = ref->next)
 355     {
 356       /* Use the existing initializer expression if it exists.
 357          Otherwise create a new one.  */
 358       if (init == NULL)
 359         expr = gfc_get_expr ();
 360       else
 361         expr = init;
 362
 363       /* Find or create this element.  */
 364       switch (ref->type)
 365         {
 366         case REF_ARRAY:
 367           if (init == NULL)
 368             {
 369               /* The element typespec will be the same as the array
 370                  typespec.  */
 371               expr->ts = *last_ts;
 372               /* Setup the expression to hold the constructor.  */
 373               expr->expr_type = EXPR_ARRAY;
 374               expr->rank = ref->u.ar.as->rank;
 375             }
 376           else
 377             gcc_assert (expr->expr_type == EXPR_ARRAY);
 378
 379           if (ref->u.ar.type == AR_ELEMENT)
 380             {
 381               get_array_index (&ref->u.ar, &offset);
 382
 383               /* This had better not be the bottom of the reference.
 384                  We can still get to a full array via a component.  */
 385               gcc_assert (ref->next != NULL);
 386             }
 387           else
 388             {
 389               mpz_set (offset, index);
 390
 391               /* We're at a full array or an array section.  This means
 392                  that we've better have found a full array, and that we're
 393                  at the bottom of the reference.  */
 394               gcc_assert (ref->u.ar.type == AR_FULL);
 395               gcc_assert (ref->next == NULL);
 396             }
 397
 398           /* Find the same element in the existing constructor.  */
 399           con = expr->value.constructor;
 400           con = find_con_by_offset (offset, con);
 401
 402           /* Create a new constructor.  */
 403           if (con == NULL)
 404             {
 405               con = gfc_get_constructor ();
 406               mpz_set (con->n.offset, offset);
 407               if (ref->next == NULL)
 408                 mpz_set (con->repeat, repeat);
 409               gfc_insert_constructor (expr, con);
 410             }
 411           else
 412             gcc_assert (ref->next != NULL);
 413           break;
 414
 415         case REF_COMPONENT:
 416           if (init == NULL)
 417             {
 418               /* Setup the expression to hold the constructor.  */
 419               expr->expr_type = EXPR_STRUCTURE;
 420               expr->ts.type = BT_DERIVED;
 421               expr->ts.derived = ref->u.c.sym;
 422             }
 423           else
 424             gcc_assert (expr->expr_type == EXPR_STRUCTURE);
 425           last_ts = &ref->u.c.component->ts;
 426
 427           /* Find the same element in the existing constructor.  */
 428           con = expr->value.constructor;
 429           con = find_con_by_component (ref->u.c.component, con);
 430
 431           if (con == NULL)
 432             {
 433               /* Create a new constructor.  */
 434               con = gfc_get_constructor ();
 435               con->n.component = ref->u.c.component;
 436               con->next = expr->value.constructor;
 437               expr->value.constructor = con;
 438             }
 439
 440           /* Since we're only intending to initialize arrays here,
 441              there better be an inner reference.  */
 442           gcc_assert (ref->next != NULL);
 443           break;
 444
 445         case REF_SUBSTRING:
 446         default:
 447           gcc_unreachable ();
 448         }
 449
 450       if (init == NULL)
 451         {
 452           /* Point the container at the new expression.  */
 453           if (last_con == NULL)
 454             symbol->value = expr;
 455           else
 456             last_con->expr = expr;
 457         }
 458       init = con->expr;
 459       last_con = con;
 460     }
 461
 462   if (last_ts->type == BT_CHARACTER)
 463     expr = create_character_intializer (init, last_ts, NULL, rvalue);
 464   else
 465     {
 466       /* We should never be overwriting an existing initializer.  */
 467       gcc_assert (!init);
 468
 469       expr = gfc_copy_expr (rvalue);
 470       if (!gfc_compare_types (&lvalue->ts, &expr->ts))
 471         gfc_convert_type (expr, &lvalue->ts, 0);
 472     }
 473
 474   if (last_con == NULL)
 475     symbol->value = expr;
 476   else
 477     last_con->expr = expr;
 478 }
 479
 480 /* Modify the index of array section and re-calculate the array offset.  */
 481
 482 void
 483 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
 484                      mpz_t *offset_ret)
 485 {
 486   int i;
 487   mpz_t delta;
 488   mpz_t tmp;
 489   bool forwards;
 490   int cmp;
 491
 492   for (i = 0; i < ar->dimen; i++)
 493     {
 494       if (ar->dimen_type[i] != DIMEN_RANGE)
 495         continue;
 496
 497       if (ar->stride[i])
 498         {
 499           mpz_add (section_index[i], section_index[i],
 500                    ar->stride[i]->value.integer);
 501         if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
 502           forwards = true;
 503         else
 504           forwards = false;
 505         }
 506       else
 507         {
 508           mpz_add_ui (section_index[i], section_index[i], 1);
 509           forwards = true;
 510         }
 511
 512       if (ar->end[i])
 513         cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
 514       else
 515         cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
 516
 517       if ((cmp > 0 && forwards)
 518           || (cmp < 0 && ! forwards))
 519         {
 520           /* Reset index to start, then loop to advance the next index.  */
 521           if (ar->start[i])
 522             mpz_set (section_index[i], ar->start[i]->value.integer);
 523           else
 524             mpz_set (section_index[i], ar->as->lower[i]->value.integer);
 525         }
 526       else
 527         break;
 528     }
 529
 530   mpz_set_si (*offset_ret, 0);
 531   mpz_init_set_si (delta, 1);
 532   mpz_init (tmp);
 533   for (i = 0; i < ar->dimen; i++)
 534     {
 535       mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
 536       mpz_mul (tmp, tmp, delta);
 537       mpz_add (*offset_ret, tmp, *offset_ret);
 538
 539       mpz_sub (tmp, ar->as->upper[i]->value.integer,
 540                ar->as->lower[i]->value.integer);
 541       mpz_add_ui (tmp, tmp, 1);
 542       mpz_mul (delta, tmp, delta);
 543     }
 544   mpz_clear (tmp);
 545   mpz_clear (delta);
 546 }
 547
 548
 549 /* Rearrange a structure constructor so the elements are in the specified
 550    order.  Also insert NULL entries if necessary.  */
 551
 552 static void
 553 formalize_structure_cons (gfc_expr * expr)
 554 {
 555   gfc_constructor *head;
 556   gfc_constructor *tail;
 557   gfc_constructor *cur;
 558   gfc_constructor *last;
 559   gfc_constructor *c;
 560   gfc_component *order;
 561
 562   c = expr->value.constructor;
 563
 564   /* Constructor is already formalized.  */
 565   if (c->n.component == NULL)
 566     return;
 567
 568   head = tail = NULL;
 569   for (order = expr->ts.derived->components; order; order = order->next)
 570     {
 571       /* Find the next component.  */
 572       last = NULL;
 573       cur = c;
 574       while (cur != NULL && cur->n.component != order)
 575         {
 576           last = cur;
 577           cur = cur->next;
 578         }
 579
 580       if (cur == NULL)
 581         {
 582           /* Create a new one.  */
 583           cur = gfc_get_constructor ();
 584         }
 585       else
 586         {
 587           /* Remove it from the chain.  */
 588           if (last == NULL)
 589             c = cur->next;
 590           else
 591             last->next = cur->next;
 592           cur->next = NULL;
 593
 594           formalize_init_expr (cur->expr);
 595         }
 596
 597       /* Add it to the new constructor.  */
 598       if (head == NULL)
 599         head = tail = cur;
 600       else
 601         {
 602           tail->next = cur;
 603           tail = tail->next;
 604         }
 605     }
 606   gcc_assert (c == NULL);
 607   expr->value.constructor = head;
 608 }
 609
 610
 611 /* Make sure an initialization expression is in normalized form.  Ie. all
 612    elements of the constructors are in the correct order.  */
 613
 614 static void
 615 formalize_init_expr (gfc_expr * expr)
 616 {
 617   expr_t type;
 618   gfc_constructor *c;
 619
 620   if (expr == NULL)
 621     return;
 622
 623   type = expr->expr_type;
 624   switch (type)
 625     {
 626     case EXPR_ARRAY:
 627       c = expr->value.constructor;
 628       while (c)
 629         {
 630           formalize_init_expr (c->expr);
 631           c = c->next;
 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