gcc/fortran/data.c

   1 /* Supporting functions for resolving DATA statement.
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software
   3    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 2, 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 COPYING.  If not, write to the Free
  20 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
  21 02110-1301, USA.  */
  22
  23
  24 /* Notes for DATA statement implementation:
  25
  26    We first assign initial value to each symbol by gfc_assign_data_value
  27    during resolveing DATA statement. Refer to check_data_variable and
  28    traverse_data_list in resolve.c.
  29
  30    The complexity exists in the handling of array section, implied do
  31    and array of struct appeared in DATA statement.
  32
  33    We call gfc_conv_structure, gfc_con_array_array_initializer,
  34    etc., to convert the initial value. Refer to trans-expr.c and
  35    trans-array.c.  */
  36
  37 #include "config.h"
  38 #include "gfortran.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 initialization 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 + 1);
 160       dest[len] = '\0';
 161       init->value.character.length = len;
 162       init->value.character.string = dest;
 163       /* Blank the string if we're only setting a substring.  */
 164       if (ref != NULL)
 165         memset (dest, ' ', len);
 166     }
 167   else
 168     dest = init->value.character.string;
 169
 170   if (ref)
 171     {
 172       gfc_expr *start_expr, *end_expr;
 173
 174       gcc_assert (ref->type == REF_SUBSTRING);
 175
 176       /* Only set a substring of the destination.  Fortran substring bounds
 177          are one-based [start, end], we want zero based [start, end).  */
 178       start_expr = gfc_copy_expr (ref->u.ss.start);
 179       end_expr = gfc_copy_expr (ref->u.ss.end);
 180
 181       if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
 182              || (gfc_simplify_expr (end_expr, 1)) == FAILURE)
 183         {
 184           gfc_error ("failure to simplify substring reference in DATA"
 185                      "statement at %L", &ref->u.ss.start->where);
 186           return NULL;
 187         }
 188
 189       gfc_extract_int (start_expr, &start);
 190       start--;
 191       gfc_extract_int (end_expr, &end);
 192     }
 193   else
 194     {
 195       /* Set the whole string.  */
 196       start = 0;
 197       end = len;
 198     }
 199
 200   /* Copy the initial value.  */
 201   len = rvalue->value.character.length;
 202   if (len > end - start)
 203     {
 204       len = end - start;
 205       gfc_warning_now ("initialization string truncated to match variable "
 206                        "at %L", &rvalue->where);
 207     }
 208
 209   memcpy (&dest[start], rvalue->value.character.string, len);
 210
 211   /* Pad with spaces.  Substrings will already be blanked.  */
 212   if (len < end - start && ref == NULL)
 213     memset (&dest[start + len], ' ', end - (start + len));
 214
 215   if (rvalue->ts.type == BT_HOLLERITH)
 216     init->from_H = 1;
 217
 218   return init;
 219 }
 220
 221 /* Assign the initial value RVALUE to  LVALUE's symbol->value. If the
 222    LVALUE already has an initialization, we extend this, otherwise we
 223    create a new one.  */
 224
 225 void
 226 gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
 227 {
 228   gfc_ref *ref;
 229   gfc_expr *init;
 230   gfc_expr *expr;
 231   gfc_constructor *con;
 232   gfc_constructor *last_con;
 233   gfc_symbol *symbol;
 234   gfc_typespec *last_ts;
 235   mpz_t offset;
 236
 237   symbol = lvalue->symtree->n.sym;
 238   init = symbol->value;
 239   last_ts = &symbol->ts;
 240   last_con = NULL;
 241   mpz_init_set_si (offset, 0);
 242
 243   /* Find/create the parent expressions for subobject references.  */
 244   for (ref = lvalue->ref; ref; ref = ref->next)
 245     {
 246       /* Break out of the loop if we find a substring.  */
 247       if (ref->type == REF_SUBSTRING)
 248         {
 249           /* A substring should always be the last subobject reference.  */
 250           gcc_assert (ref->next == NULL);
 251           break;
 252         }
 253
 254       /* Use the existing initializer expression if it exists.  Otherwise
 255          create a new one.  */
 256       if (init == NULL)
 257         expr = gfc_get_expr ();
 258       else
 259         expr = init;
 260
 261       /* Find or create this element.  */
 262       switch (ref->type)
 263         {
 264         case REF_ARRAY:
 265           if (init == NULL)
 266             {
 267               /* The element typespec will be the same as the array
 268                  typespec.  */
 269               expr->ts = *last_ts;
 270               /* Setup the expression to hold the constructor.  */
 271               expr->expr_type = EXPR_ARRAY;
 272               expr->rank = ref->u.ar.as->rank;
 273             }
 274           else
 275             gcc_assert (expr->expr_type == EXPR_ARRAY);
 276
 277           if (ref->u.ar.type == AR_ELEMENT)
 278             get_array_index (&ref->u.ar, &offset);
 279           else
 280             mpz_set (offset, index);
 281
 282           /* Find the same element in the existing constructor.  */
 283           con = expr->value.constructor;
 284           con = find_con_by_offset (offset, con);
 285
 286           if (con == NULL)
 287             {
 288               /* Create a new constructor.  */
 289               con = gfc_get_constructor ();
 290               mpz_set (con->n.offset, offset);
 291               gfc_insert_constructor (expr, con);
 292             }
 293           break;
 294
 295         case REF_COMPONENT:
 296           if (init == NULL)
 297             {
 298               /* Setup the expression to hold the constructor.  */
 299               expr->expr_type = EXPR_STRUCTURE;
 300               expr->ts.type = BT_DERIVED;
 301               expr->ts.derived = ref->u.c.sym;
 302             }
 303           else
 304             gcc_assert (expr->expr_type == EXPR_STRUCTURE);
 305           last_ts = &ref->u.c.component->ts;
 306
 307           /* Find the same element in the existing constructor.  */
 308           con = expr->value.constructor;
 309           con = find_con_by_component (ref->u.c.component, con);
 310
 311           if (con == NULL)
 312             {
 313               /* Create a new constructor.  */
 314               con = gfc_get_constructor ();
 315               con->n.component = ref->u.c.component;
 316               con->next = expr->value.constructor;
 317               expr->value.constructor = con;
 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     expr = create_character_intializer (init, last_ts, ref, rvalue);
 339   else
 340     {
 341       /* Overwriting an existing initializer is non-standard but usually only
 342          provokes a warning from other compilers.  */
 343       if (init != NULL)
 344         {
 345           /* Order in which the expressions arrive here depends on whether they
 346              are from data statements or F95 style declarations. Therefore,
 347              check which is the most recent.  */
 348 #ifdef USE_MAPPED_LOCATION
 349           expr = (LOCATION_LINE (init->where.lb->location)
 350                   > LOCATION_LINE (rvalue->where.lb->location))
 351             ? init : rvalue;
 352 #else
 353           expr = (init->where.lb->linenum > rvalue->where.lb->linenum) ?
 354                     init : rvalue;
 355 #endif
 356           gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization "
 357                           "of '%s' at %L",  symbol->name, &expr->where);
 358         }
 359
 360       expr = gfc_copy_expr (rvalue);
 361       if (!gfc_compare_types (&lvalue->ts, &expr->ts))
 362         gfc_convert_type (expr, &lvalue->ts, 0);
 363     }
 364
 365   if (last_con == NULL)
 366     symbol->value = expr;
 367   else
 368     last_con->expr = expr;
 369 }
 370
 371 /* Similarly, but initialize REPEAT consecutive values in LVALUE the same
 372    value in RVALUE.  For the nonce, LVALUE must refer to a full array, not
 373    an array section.  */
 374
 375 void
 376 gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue,
 377                              mpz_t index, mpz_t repeat)
 378 {
 379   gfc_ref *ref;
 380   gfc_expr *init, *expr;
 381   gfc_constructor *con, *last_con;
 382   gfc_symbol *symbol;
 383   gfc_typespec *last_ts;
 384   mpz_t offset;
 385
 386   symbol = lvalue->symtree->n.sym;
 387   init = symbol->value;
 388   last_ts = &symbol->ts;
 389   last_con = NULL;
 390   mpz_init_set_si (offset, 0);
 391
 392   /* Find/create the parent expressions for subobject references.  */
 393   for (ref = lvalue->ref; ref; ref = ref->next)
 394     {
 395       /* Use the existing initializer expression if it exists.
 396          Otherwise create a new one.  */
 397       if (init == NULL)
 398         expr = gfc_get_expr ();
 399       else
 400         expr = init;
 401
 402       /* Find or create this element.  */
 403       switch (ref->type)
 404         {
 405         case REF_ARRAY:
 406           if (init == NULL)
 407             {
 408               /* The element typespec will be the same as the array
 409                  typespec.  */
 410               expr->ts = *last_ts;
 411               /* Setup the expression to hold the constructor.  */
 412               expr->expr_type = EXPR_ARRAY;
 413               expr->rank = ref->u.ar.as->rank;
 414             }
 415           else
 416             gcc_assert (expr->expr_type == EXPR_ARRAY);
 417
 418           if (ref->u.ar.type == AR_ELEMENT)
 419             {
 420               get_array_index (&ref->u.ar, &offset);
 421
 422               /* This had better not be the bottom of the reference.
 423                  We can still get to a full array via a component.  */
 424               gcc_assert (ref->next != NULL);
 425             }
 426           else
 427             {
 428               mpz_set (offset, index);
 429
 430               /* We're at a full array or an array section.  This means
 431                  that we've better have found a full array, and that we're
 432                  at the bottom of the reference.  */
 433               gcc_assert (ref->u.ar.type == AR_FULL);
 434               gcc_assert (ref->next == NULL);
 435             }
 436
 437           /* Find the same element in the existing constructor.  */
 438           con = expr->value.constructor;
 439           con = find_con_by_offset (offset, con);
 440
 441           /* Create a new constructor.  */
 442           if (con == NULL)
 443             {
 444               con = gfc_get_constructor ();
 445               mpz_set (con->n.offset, offset);
 446               if (ref->next == NULL)
 447                 mpz_set (con->repeat, repeat);
 448               gfc_insert_constructor (expr, con);
 449             }
 450           else
 451             gcc_assert (ref->next != NULL);
 452           break;
 453
 454         case REF_COMPONENT:
 455           if (init == NULL)
 456             {
 457               /* Setup the expression to hold the constructor.  */
 458               expr->expr_type = EXPR_STRUCTURE;
 459               expr->ts.type = BT_DERIVED;
 460               expr->ts.derived = ref->u.c.sym;
 461             }
 462           else
 463             gcc_assert (expr->expr_type == EXPR_STRUCTURE);
 464           last_ts = &ref->u.c.component->ts;
 465
 466           /* Find the same element in the existing constructor.  */
 467           con = expr->value.constructor;
 468           con = find_con_by_component (ref->u.c.component, con);
 469
 470           if (con == NULL)
 471             {
 472               /* Create a new constructor.  */
 473               con = gfc_get_constructor ();
 474               con->n.component = ref->u.c.component;
 475               con->next = expr->value.constructor;
 476               expr->value.constructor = con;
 477             }
 478
 479           /* Since we're only intending to initialize arrays here,
 480              there better be an inner reference.  */
 481           gcc_assert (ref->next != NULL);
 482           break;
 483
 484         case REF_SUBSTRING:
 485         default:
 486           gcc_unreachable ();
 487         }
 488
 489       if (init == NULL)
 490         {
 491           /* Point the container at the new expression.  */
 492           if (last_con == NULL)
 493             symbol->value = expr;
 494           else
 495             last_con->expr = expr;
 496         }
 497       init = con->expr;
 498       last_con = con;
 499     }
 500
 501   if (last_ts->type == BT_CHARACTER)
 502     expr = create_character_intializer (init, last_ts, NULL, rvalue);
 503   else
 504     {
 505       /* We should never be overwriting an existing initializer.  */
 506       gcc_assert (!init);
 507
 508       expr = gfc_copy_expr (rvalue);
 509       if (!gfc_compare_types (&lvalue->ts, &expr->ts))
 510         gfc_convert_type (expr, &lvalue->ts, 0);
 511     }
 512
 513   if (last_con == NULL)
 514     symbol->value = expr;
 515   else
 516     last_con->expr = expr;
 517 }
 518
 519 /* Modify the index of array section and re-calculate the array offset.  */
 520
 521 void
 522 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
 523                      mpz_t *offset_ret)
 524 {
 525   int i;
 526   mpz_t delta;
 527   mpz_t tmp;
 528   bool forwards;
 529   int cmp;
 530
 531   for (i = 0; i < ar->dimen; i++)
 532     {
 533       if (ar->dimen_type[i] != DIMEN_RANGE)
 534         continue;
 535
 536       if (ar->stride[i])
 537         {
 538           mpz_add (section_index[i], section_index[i],
 539                    ar->stride[i]->value.integer);
 540         if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
 541           forwards = true;
 542         else
 543           forwards = false;
 544         }
 545       else
 546         {
 547           mpz_add_ui (section_index[i], section_index[i], 1);
 548           forwards = true;
 549         }
 550
 551       if (ar->end[i])
 552         cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
 553       else
 554         cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
 555
 556       if ((cmp > 0 && forwards)
 557           || (cmp < 0 && ! forwards))
 558         {
 559           /* Reset index to start, then loop to advance the next index.  */
 560           if (ar->start[i])
 561             mpz_set (section_index[i], ar->start[i]->value.integer);
 562           else
 563             mpz_set (section_index[i], ar->as->lower[i]->value.integer);
 564         }
 565       else
 566         break;
 567     }
 568
 569   mpz_set_si (*offset_ret, 0);
 570   mpz_init_set_si (delta, 1);
 571   mpz_init (tmp);
 572   for (i = 0; i < ar->dimen; i++)
 573     {
 574       mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
 575       mpz_mul (tmp, tmp, delta);
 576       mpz_add (*offset_ret, tmp, *offset_ret);
 577
 578       mpz_sub (tmp, ar->as->upper[i]->value.integer,
 579                ar->as->lower[i]->value.integer);
 580       mpz_add_ui (tmp, tmp, 1);
 581       mpz_mul (delta, tmp, delta);
 582     }
 583   mpz_clear (tmp);
 584   mpz_clear (delta);
 585 }
 586
 587
 588 /* Rearrange a structure constructor so the elements are in the specified
 589    order.  Also insert NULL entries if necessary.  */
 590
 591 static void
 592 formalize_structure_cons (gfc_expr * expr)
 593 {
 594   gfc_constructor *head;
 595   gfc_constructor *tail;
 596   gfc_constructor *cur;
 597   gfc_constructor *last;
 598   gfc_constructor *c;
 599   gfc_component *order;
 600
 601   c = expr->value.constructor;
 602
 603   /* Constructor is already formalized.  */
 604   if (c->n.component == NULL)
 605     return;
 606
 607   head = tail = NULL;
 608   for (order = expr->ts.derived->components; order; order = order->next)
 609     {
 610       /* Find the next component.  */
 611       last = NULL;
 612       cur = c;
 613       while (cur != NULL && cur->n.component != order)
 614         {
 615           last = cur;
 616           cur = cur->next;
 617         }
 618
 619       if (cur == NULL)
 620         {
 621           /* Create a new one.  */
 622           cur = gfc_get_constructor ();
 623         }
 624       else
 625         {
 626           /* Remove it from the chain.  */
 627           if (last == NULL)
 628             c = cur->next;
 629           else
 630             last->next = cur->next;
 631           cur->next = NULL;
 632
 633           formalize_init_expr (cur->expr);
 634         }
 635
 636       /* Add it to the new constructor.  */
 637       if (head == NULL)
 638         head = tail = cur;
 639       else
 640         {
 641           tail->next = cur;
 642           tail = tail->next;
 643         }
 644     }
 645   gcc_assert (c == NULL);
 646   expr->value.constructor = head;
 647 }
 648
 649
 650 /* Make sure an initialization expression is in normalized form.  Ie. all
 651    elements of the constructors are in the correct order.  */
 652
 653 static void
 654 formalize_init_expr (gfc_expr * expr)
 655 {
 656   expr_t type;
 657   gfc_constructor *c;
 658
 659   if (expr == NULL)
 660     return;
 661
 662   type = expr->expr_type;
 663   switch (type)
 664     {
 665     case EXPR_ARRAY:
 666       c = expr->value.constructor;
 667       while (c)
 668         {
 669           formalize_init_expr (c->expr);
 670           c = c->next;
 671         }
 672       break;
 673
 674     case EXPR_STRUCTURE:
 675       formalize_structure_cons (expr);
 676       break;
 677
 678     default:
 679       break;
 680     }
 681 }
 682
 683
 684 /* Resolve symbol's initial value after all data statement.  */
 685
 686 void
 687 gfc_formalize_init_value (gfc_symbol *sym)
 688 {
 689   formalize_init_expr (sym->value);
 690 }
 691
 692
 693 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
 694    offset.  */
 695
 696 void
 697 gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
 698 {
 699   int i;
 700   mpz_t delta;
 701   mpz_t tmp;
 702
 703   mpz_set_si (*offset, 0);
 704   mpz_init (tmp);
 705   mpz_init_set_si (delta, 1);
 706   for (i = 0; i < ar->dimen; i++)
 707     {
 708       mpz_init (section_index[i]);
 709       switch (ar->dimen_type[i])
 710         {
 711         case DIMEN_ELEMENT:
 712         case DIMEN_RANGE:
 713           if (ar->start[i])
 714             {
 715               mpz_sub (tmp, ar->start[i]->value.integer,
 716                        ar->as->lower[i]->value.integer);
 717               mpz_mul (tmp, tmp, delta);
 718               mpz_add (*offset, tmp, *offset);
 719               mpz_set (section_index[i], ar->start[i]->value.integer);
 720             }
 721           else
 722               mpz_set (section_index[i], ar->as->lower[i]->value.integer);
 723           break;
 724
 725         case DIMEN_VECTOR:
 726           gfc_internal_error ("TODO: Vector sections in data statements");
 727
 728         default:
 729           gcc_unreachable ();
 730         }
 731
 732       mpz_sub (tmp, ar->as->upper[i]->value.integer,
 733                ar->as->lower[i]->value.integer);
 734       mpz_add_ui (tmp, tmp, 1);
 735       mpz_mul (delta, tmp, delta);
 736     }
 737
 738   mpz_clear (tmp);
 739   mpz_clear (delta);
 740 }
 741