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