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   for (; con; con = con->next)
  86     {
  87       if (mpz_cmp (offset, con->n.offset) == 0)
  88         return con;
  89     }
  90   return NULL;
  91 }
  92
  93
  94 /* Find if there is a constructor which component is equal to COM.  */
  95
  96 static gfc_constructor *
  97 find_con_by_component (gfc_component *com, gfc_constructor *con)
  98 {
  99   for (; con; con = con->next)
 100     {
 101       if (com == con->n.component)
 102         return con;
 103     }
 104   return NULL;
 105 }
 106
 107
 108 /* Create a character type intialization expression from RVALUE.
 109    TS [and REF] describe [the substring of] the variable being initialized.
 110    INIT is thh existing initializer, not NULL.  Initialization is performed
 111    according to normal assignment rules.  */
 112
 113 static gfc_expr *
 114 create_character_intializer (gfc_expr * init, gfc_typespec * ts,
 115                              gfc_ref * ref, gfc_expr * rvalue)
 116 {
 117   int len;
 118   int start;
 119   int end;
 120   char *dest;
 121
 122   gfc_extract_int (ts->cl->length, &len);
 123
 124   if (init == NULL)
 125     {
 126       /* Create a new initializer.  */
 127       init = gfc_get_expr ();
 128       init->expr_type = EXPR_CONSTANT;
 129       init->ts = *ts;
 130
 131       dest = gfc_getmem (len);
 132       init->value.character.length = len;
 133       init->value.character.string = dest;
 134       /* Blank the string if we're only setting a substring.  */
 135       if (ref != NULL)
 136         memset (dest, ' ', len);
 137     }
 138   else
 139     dest = init->value.character.string;
 140
 141   if (ref)
 142     {
 143       assert (ref->type == REF_SUBSTRING);
 144
 145       /* Only set a substring of the destination.  Fortran substring bounds
 146          are one-based [start, end], we want zero based [start, end).  */
 147       gfc_extract_int (ref->u.ss.start, &start);
 148       start--;
 149       gfc_extract_int (ref->u.ss.end, &end);
 150     }
 151   else
 152     {
 153       /* Set the whole string.  */
 154       start = 0;
 155       end = len;
 156     }
 157
 158   /* Copy the initial value.  */
 159   len = rvalue->value.character.length;
 160   if (len > end - start)
 161     len = end - start;
 162   memcpy (&dest[start], rvalue->value.character.string, len);
 163
 164   /* Pad with spaces.  Substrings will already be blanked.  */
 165   if (len < end - start && ref == NULL)
 166     memset (&dest[start + len], ' ', end - (start + len));
 167
 168   return init;
 169 }
 170
 171 /* Assign the initial value RVALUE to  LVALUE's symbol->value. If the
 172    LVALUE already has an initialization, we extend this, otherwise we
 173    create a new one.  */
 174
 175 void
 176 gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
 177 {
 178   gfc_ref *ref;
 179   gfc_expr *init;
 180   gfc_expr *expr;
 181   gfc_constructor *con;
 182   gfc_constructor *last_con;
 183   gfc_symbol *symbol;
 184   gfc_typespec *last_ts;
 185   mpz_t offset;
 186
 187   symbol = lvalue->symtree->n.sym;
 188   init = symbol->value;
 189   last_ts = &symbol->ts;
 190   last_con = NULL;
 191   mpz_init_set_si (offset, 0);
 192
 193   /* Find/create the parent expressions for subobject references.  */
 194   for (ref = lvalue->ref; ref; ref = ref->next)
 195     {
 196       /* Break out of the loop if we find a substring.  */
 197       if (ref->type == REF_SUBSTRING)
 198         {
 199           /* A substring should always br the last subobject reference.  */
 200           assert (ref->next == NULL);
 201           break;
 202         }
 203
 204       /* Use the existing initializer expression if it exists.  Otherwise
 205          create a new one.  */
 206       if (init == NULL)
 207         expr = gfc_get_expr ();
 208       else
 209         expr = init;
 210
 211       /* Find or create this element.  */
 212       switch (ref->type)
 213         {
 214         case REF_ARRAY:
 215           if (init == NULL)
 216             {
 217               /* The element typespec will be the same as the array
 218                  typespec.  */
 219               expr->ts = *last_ts;
 220               /* Setup the expression to hold the constructor.  */
 221               expr->expr_type = EXPR_ARRAY;
 222               expr->rank = ref->u.ar.as->rank;
 223             }
 224           else
 225             assert (expr->expr_type == EXPR_ARRAY);
 226
 227           if (ref->u.ar.type == AR_ELEMENT)
 228             get_array_index (&ref->u.ar, &offset);
 229           else
 230             mpz_set (offset, index);
 231
 232           /* Find the same element in the existing constructor.  */
 233           con = expr->value.constructor;
 234           con = find_con_by_offset (offset, con);
 235
 236           if (con == NULL)
 237             {
 238               /* Create a new constructor.  */
 239               con = gfc_get_constructor();
 240               mpz_set (con->n.offset, offset);
 241               gfc_insert_constructor (expr, con);
 242             }
 243           break;
 244
 245         case REF_COMPONENT:
 246           if (init == NULL)
 247             {
 248               /* Setup the expression to hold the constructor.  */
 249               expr->expr_type = EXPR_STRUCTURE;
 250               expr->ts.type = BT_DERIVED;
 251               expr->ts.derived = ref->u.c.sym;
 252             }
 253           else
 254             assert (expr->expr_type == EXPR_STRUCTURE);
 255           last_ts = &ref->u.c.component->ts;
 256
 257           /* Find the same element in the existing constructor.  */
 258           con = expr->value.constructor;
 259           con = find_con_by_component (ref->u.c.component, con);
 260
 261           if (con == NULL)
 262             {
 263               /* Create a new constructor.  */
 264               con = gfc_get_constructor ();
 265               con->n.component = ref->u.c.component;
 266               con->next = expr->value.constructor;
 267               expr->value.constructor = con;
 268             }
 269           break;
 270
 271         default:
 272           abort ();
 273         }
 274
 275
 276       if (init == NULL)
 277         {
 278           /* Point the container at the new expression.  */
 279           if (last_con == NULL)
 280             symbol->value = expr;
 281           else
 282             last_con->expr = expr;
 283         }
 284       init = con->expr;
 285       last_con = con;
 286     }
 287
 288   if (ref || last_ts->type == BT_CHARACTER)
 289     expr = create_character_intializer (init, last_ts, ref, rvalue);
 290   else
 291     {
 292       /* We should never be overwriting an existing initializer.  */
 293       assert (!init);
 294
 295       expr = gfc_copy_expr (rvalue);
 296       if (!gfc_compare_types (&lvalue->ts, &expr->ts))
 297         gfc_convert_type (expr, &lvalue->ts, 0);
 298
 299     }
 300
 301   if (last_con == NULL)
 302     symbol->value = expr;
 303   else
 304     last_con->expr = expr;
 305 }
 306
 307
 308 /* Modify the index of array section and re-calculate the array offset.  */
 309
 310 void
 311 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
 312                      mpz_t *offset_ret)
 313 {
 314   int i;
 315   mpz_t delta;
 316   mpz_t tmp;
 317   bool forwards;
 318   int cmp;
 319
 320   for (i = 0; i < ar->dimen; i++)
 321     {
 322       if (ar->dimen_type[i] != DIMEN_RANGE)
 323         continue;
 324
 325       if (ar->stride[i])
 326         {
 327           mpz_add (section_index[i], section_index[i],
 328                    ar->stride[i]->value.integer);
 329         if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
 330           forwards = true;
 331         else
 332           forwards = false;
 333         }
 334       else
 335         {
 336           mpz_add_ui (section_index[i], section_index[i], 1);
 337           forwards = true;
 338         }
 339
 340       if (ar->end[i])
 341         cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
 342       else
 343         cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
 344
 345       if ((cmp > 0 && forwards)
 346           || (cmp < 0 && ! forwards))
 347         {
 348           /* Reset index to start, then loop to advance the next index.  */
 349           if (ar->start[i])
 350             mpz_set (section_index[i], ar->start[i]->value.integer);
 351           else
 352             mpz_set (section_index[i], ar->as->lower[i]->value.integer);
 353         }
 354       else
 355         break;
 356     }
 357
 358   mpz_set_si (*offset_ret, 0);
 359   mpz_init_set_si (delta, 1);
 360   mpz_init (tmp);
 361   for (i = 0; i < ar->dimen; i++)
 362     {
 363       mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
 364       mpz_mul (tmp, tmp, delta);
 365       mpz_add (*offset_ret, tmp, *offset_ret);
 366
 367       mpz_sub (tmp, ar->as->upper[i]->value.integer,
 368                ar->as->lower[i]->value.integer);
 369       mpz_add_ui (tmp, tmp, 1);
 370       mpz_mul (delta, tmp, delta);
 371     }
 372   mpz_clear (tmp);
 373   mpz_clear (delta);
 374 }
 375
 376
 377 /* Rearrange a structure constructor so the elements are in the specified
 378    order.  Also insert NULL entries if neccessary.  */
 379
 380 static void
 381 formalize_structure_cons (gfc_expr * expr)
 382 {
 383   gfc_constructor *head;
 384   gfc_constructor *tail;
 385   gfc_constructor *cur;
 386   gfc_constructor *last;
 387   gfc_constructor *c;
 388   gfc_component *order;
 389
 390   c = expr->value.constructor;
 391
 392   /* Constructor is already fomalized.  */
 393   if (c->n.component == NULL)
 394     return;
 395
 396   head = tail = NULL;
 397   for (order = expr->ts.derived->components; order; order = order->next)
 398     {
 399       /* Find the next component.  */
 400       last = NULL;
 401       cur = c;
 402       while (cur != NULL && cur->n.component != order)
 403         {
 404           last = cur;
 405           cur = cur->next;
 406         }
 407
 408       if (cur == NULL)
 409         {
 410           /* Create a new one.  */
 411           cur = gfc_get_constructor ();
 412         }
 413       else
 414         {
 415           /* Remove it from the chain.  */
 416           if (last == NULL)
 417             c = cur->next;
 418           else
 419             last->next = cur->next;
 420           cur->next = NULL;
 421
 422           formalize_init_expr (cur->expr);
 423         }
 424
 425       /* Add it to the new constructor.  */
 426       if (head == NULL)
 427         head = tail = cur;
 428       else
 429         {
 430           tail->next = cur;
 431           tail = tail->next;
 432         }
 433     }
 434   assert (c == NULL);
 435   expr->value.constructor = head;
 436 }
 437
 438
 439 /* Make sure an initialization expression is in normalized form.  Ie. all
 440    elements of the constructors are in the correct order.  */
 441
 442 static void
 443 formalize_init_expr (gfc_expr * expr)
 444 {
 445   expr_t type;
 446   gfc_constructor *c;
 447
 448   if (expr == NULL)
 449     return;
 450
 451   type = expr->expr_type;
 452   switch (type)
 453     {
 454     case EXPR_ARRAY:
 455       c = expr->value.constructor;
 456       while (c)
 457         {
 458           formalize_init_expr (c->expr);
 459           c = c->next;
 460         }
 461       break;
 462
 463     case EXPR_STRUCTURE:
 464       formalize_structure_cons (expr);
 465       break;
 466
 467     default:
 468       break;
 469     }
 470 }
 471
 472
 473 /* Resolve symbol's initial value after all data statement.  */
 474
 475 void
 476 gfc_formalize_init_value (gfc_symbol *sym)
 477 {
 478   formalize_init_expr (sym->value);
 479 }
 480
 481
 482 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
 483    offset.  */
 484
 485 void
 486 gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
 487 {
 488   int i;
 489   mpz_t delta;
 490   mpz_t tmp;
 491
 492   mpz_set_si (*offset, 0);
 493   mpz_init (tmp);
 494   mpz_init_set_si (delta, 1);
 495   for (i = 0; i < ar->dimen; i++)
 496     {
 497       mpz_init (section_index[i]);
 498       switch (ar->dimen_type[i])
 499         {
 500         case DIMEN_ELEMENT:
 501         case DIMEN_RANGE:
 502           if (ar->start[i])
 503             {
 504               mpz_sub (tmp, ar->start[i]->value.integer,
 505                        ar->as->lower[i]->value.integer);
 506               mpz_mul (tmp, tmp, delta);
 507               mpz_add (*offset, tmp, *offset);
 508               mpz_set (section_index[i], ar->start[i]->value.integer);
 509             }
 510           else
 511               mpz_set (section_index[i], ar->as->lower[i]->value.integer);
 512           break;
 513
 514         case DIMEN_VECTOR:
 515           gfc_internal_error ("TODO: Vector sections in data statements");
 516
 517         default:
 518           abort ();
 519         }
 520
 521       mpz_sub (tmp, ar->as->upper[i]->value.integer,
 522                ar->as->lower[i]->value.integer);
 523       mpz_add_ui (tmp, tmp, 1);
 524       mpz_mul (delta, tmp, delta);
 525     }
 526
 527   mpz_clear (tmp);
 528   mpz_clear (delta);
 529 }
 530