1/* equiv.c -- Implementation File (module.c template V1.0) 2 Copyright (C) 1995-1998 Free Software Foundation, Inc. 3 Contributed by James Craig Burley. 4 5This file is part of GNU Fortran. 6 7GNU Fortran is free software; you can redistribute it and/or modify 8it under the terms of the GNU General Public License as published by 9the Free Software Foundation; either version 2, or (at your option) 10any later version. 11 12GNU Fortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17You should have received a copy of the GNU General Public License 18along with GNU Fortran; see the file COPYING. If not, write to 19the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 2002111-1307, USA. 21 22 Related Modules: 23 None 24 25 Description: 26 Handles the EQUIVALENCE relationships in a program unit. 27 28 Modifications: 29*/ 30 31#define FFEEQUIV_DEBUG 0 32 33/* Include files. */ 34 35#include "proj.h" 36#include "equiv.h" 37#include "bad.h" 38#include "bld.h" 39#include "com.h" 40#include "data.h" 41#include "global.h" 42#include "lex.h" 43#include "malloc.h" 44#include "symbol.h" 45 46/* Externals defined here. */ 47 48 49/* Simple definitions and enumerations. */ 50 51 52/* Internal typedefs. */ 53 54 55/* Private include files. */ 56 57 58/* Internal structure definitions. */ 59 60struct _ffeequiv_list_ 61 { 62 ffeequiv first; 63 ffeequiv last; 64 }; 65 66/* Static objects accessed by functions in this module. */ 67 68static struct _ffeequiv_list_ ffeequiv_list_; 69 70/* Static functions (internal). */ 71 72static void ffeequiv_destroy_ (ffeequiv eq); 73static void ffeequiv_layout_local_ (ffeequiv eq); 74static bool ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s, 75 ffebld expr, bool subtract, 76 ffetargetOffset adjust, bool no_precede); 77 78/* Internal macros. */ 79 80 81static void 82ffeequiv_destroy_ (ffeequiv victim) 83{ 84 ffebld list; 85 ffebld item; 86 ffebld expr; 87 88 for (list = victim->list; list != NULL; list = ffebld_trail (list)) 89 { 90 for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item)) 91 { 92 ffesymbol sym; 93 94 expr = ffebld_head (item); 95 sym = ffeequiv_symbol (expr); 96 if (sym == NULL) 97 continue; 98 if (ffesymbol_equiv (sym) != NULL) 99 ffesymbol_set_equiv (sym, NULL); 100 } 101 } 102 ffeequiv_kill (victim); 103} 104 105/* ffeequiv_layout_local_ -- Lay out storage for local equivalenced vars 106 107 ffeequiv eq; 108 ffeequiv_layout_local_(eq); 109 110 Makes a single master ffestorag object that contains all the vars 111 in the equivalence, and makes subordinate ffestorag objects for the 112 vars with the correct offsets. 113 114 The resulting var offsets are relative not necessarily to 0 -- the 115 are relative to the offset of the master area, which might be 0 or 116 negative, but should never be positive. */ 117 118static void 119ffeequiv_layout_local_ (ffeequiv eq) 120{ 121 ffestorag st; /* Equivalence storage area. */ 122 ffebld list; /* List of list of equivalences. */ 123 ffebld item; /* List of equivalences. */ 124 ffebld root_exp; /* Expression for root sym. */ 125 ffestorag root_st; /* Storage for root. */ 126 ffesymbol root_sym; /* Root itself. */ 127 ffebld rooted_exp; /* Expression for rooted sym in an eqlist. */ 128 ffestorag rooted_st; /* Storage for rooted. */ 129 ffesymbol rooted_sym; /* Rooted symbol itself. */ 130 ffetargetOffset eqlist_offset;/* Offset for eqlist from rooted sym. */ 131 ffetargetAlign alignment; 132 ffetargetAlign modulo; 133 ffetargetAlign pad; 134 ffetargetOffset size; 135 ffetargetOffset num_elements; 136 bool new_storage; /* Established new storage info. */ 137 bool need_storage; /* Have need for more storage info. */ 138 bool init; 139 140 assert (eq != NULL); 141 142 if (ffeequiv_common (eq) != NULL) 143 { /* Put in common due to programmer error. */ 144 ffeequiv_destroy_ (eq); 145 return; 146 } 147 148 /* Find the symbol for the first valid item in the list of lists, use that 149 as the root symbol. Doesn't matter if it won't end up at the beginning 150 of the list, though. */ 151 152#if FFEEQUIV_DEBUG 153 fprintf (stderr, "Equiv1:\n"); 154#endif 155 156 root_sym = NULL; 157 root_exp = NULL; 158 159 for (list = ffeequiv_list (eq); 160 list != NULL; 161 list = ffebld_trail (list)) 162 { /* For every equivalence list in the list of 163 equivs */ 164 for (item = ffebld_head (list); 165 item != NULL; 166 item = ffebld_trail (item)) 167 { /* For every equivalence item in the list */ 168 ffetargetOffset ign; /* Ignored. */ 169 170 root_exp = ffebld_head (item); 171 root_sym = ffeequiv_symbol (root_exp); 172 if (root_sym == NULL) 173 continue; /* Ignore me. */ 174 175 assert (ffesymbol_storage (root_sym) == NULL); /* No storage yet. */ 176 177 if (!ffeequiv_offset_ (&ign, root_sym, root_exp, FALSE, 0, FALSE)) 178 { 179 /* We can't just eliminate this one symbol from the list 180 of candidates, because it might be the only one that 181 ties all these equivs together. So just destroy the 182 whole list. */ 183 184 ffeequiv_destroy_ (eq); 185 return; 186 } 187 188 break; /* Use first valid eqv expr for root exp/sym. */ 189 } 190 if (root_sym != NULL) 191 break; 192 } 193 194 if (root_sym == NULL) 195 { 196 ffeequiv_destroy_ (eq); 197 return; 198 } 199 200 201#if FFEEQUIV_DEBUG 202 fprintf (stderr, " Root: `%s'\n", ffesymbol_text (root_sym)); 203#endif 204 205 /* We've got work to do, so make the LOCAL storage object that'll hold all 206 the equivalenced vars inside it. */ 207 208 st = ffestorag_new (ffestorag_list_master ()); 209 ffestorag_set_parent (st, NULL); /* Initializations happen here. */ 210 ffestorag_set_init (st, NULL); 211 ffestorag_set_accretion (st, NULL); 212 ffestorag_set_offset (st, 0); /* Assume equiv will be at root offset 0 for now. */ 213 ffestorag_set_alignment (st, 1); 214 ffestorag_set_modulo (st, 0); 215 ffestorag_set_type (st, FFESTORAG_typeLOCAL); 216 ffestorag_set_basictype (st, ffesymbol_basictype (root_sym)); 217 ffestorag_set_kindtype (st, ffesymbol_kindtype (root_sym)); 218 ffestorag_set_typesymbol (st, root_sym); 219 ffestorag_set_is_save (st, ffeequiv_is_save (eq)); 220 if (ffesymbol_is_save (root_sym)) 221 ffestorag_update_save (st); 222 ffestorag_set_is_init (st, ffeequiv_is_init (eq)); 223 if (ffesymbol_is_init (root_sym)) 224 ffestorag_update_init (st); 225 ffestorag_set_symbol (st, root_sym); /* Assume this will be the root until 226 we know better (used only to generate 227 the internal name for the aggregate area, 228 e.g. for debugging). */ 229 230 /* Make the EQUIV storage object for the root symbol. */ 231 232 if (ffesymbol_rank (root_sym) == 0) 233 num_elements = 1; 234 else 235 num_elements = ffebld_constant_integerdefault (ffebld_conter 236 (ffesymbol_arraysize (root_sym))); 237 ffetarget_layout (ffesymbol_text (root_sym), &alignment, &modulo, &size, 238 ffesymbol_basictype (root_sym), ffesymbol_kindtype (root_sym), 239 ffesymbol_size (root_sym), num_elements); 240 ffestorag_set_size (st, size); /* Set initial size of aggregate area. */ 241 242 pad = ffetarget_align (ffestorag_ptr_to_alignment (st), 243 ffestorag_ptr_to_modulo (st), 0, alignment, 244 modulo); 245 assert (pad == 0); 246 247 root_st = ffestorag_new (ffestorag_list_equivs (st)); 248 ffestorag_set_parent (root_st, st); /* Initializations happen there. */ 249 ffestorag_set_init (root_st, NULL); 250 ffestorag_set_accretion (root_st, NULL); 251 ffestorag_set_symbol (root_st, root_sym); 252 ffestorag_set_size (root_st, size); 253 ffestorag_set_offset (root_st, 0); /* Will not change; always 0 relative to itself! */ 254 ffestorag_set_alignment (root_st, alignment); 255 ffestorag_set_modulo (root_st, modulo); 256 ffestorag_set_type (root_st, FFESTORAG_typeEQUIV); 257 ffestorag_set_basictype (root_st, ffesymbol_basictype (root_sym)); 258 ffestorag_set_kindtype (root_st, ffesymbol_kindtype (root_sym)); 259 ffestorag_set_typesymbol (root_st, root_sym); 260 ffestorag_set_is_save (root_st, FALSE); /* Assume FALSE, then... */ 261 if (ffestorag_is_save (st)) /* ...update to TRUE if needed. */ 262 ffestorag_update_save (root_st); 263 ffestorag_set_is_init (root_st, FALSE); /* Assume FALSE, then... */ 264 if (ffestorag_is_init (st)) /* ...update to TRUE if needed. */ 265 ffestorag_update_init (root_st); 266 ffesymbol_set_storage (root_sym, root_st); 267 ffesymbol_signal_unreported (root_sym); 268 init = ffesymbol_is_init (root_sym); 269 270 /* Now that we know the root (offset=0) symbol, revisit all the lists and 271 do the actual storage allocation. Keep doing this until we've gone 272 through them all without making any new storage objects. */ 273 274 do 275 { 276 new_storage = FALSE; 277 need_storage = FALSE; 278 for (list = ffeequiv_list (eq); 279 list != NULL; 280 list = ffebld_trail (list)) 281 { /* For every equivalence list in the list of 282 equivs */ 283 /* Now find a "rooted" symbol in this list. That is, find the 284 first item we can that is valid and whose symbol already 285 has a storage area, because that means we know where it 286 belongs in the equivalence area and can then allocate the 287 rest of the items in the list accordingly. */ 288 289 rooted_sym = NULL; 290 rooted_exp = NULL; 291 eqlist_offset = 0; 292 293 for (item = ffebld_head (list); 294 item != NULL; 295 item = ffebld_trail (item)) 296 { /* For every equivalence item in the list */ 297 rooted_exp = ffebld_head (item); 298 rooted_sym = ffeequiv_symbol (rooted_exp); 299 if ((rooted_sym == NULL) 300 || ((rooted_st = ffesymbol_storage (rooted_sym)) == NULL)) 301 { 302 rooted_sym = NULL; 303 continue; /* Ignore me. */ 304 } 305 306 need_storage = TRUE; /* Somebody is likely to need 307 storage. */ 308 309#if FFEEQUIV_DEBUG 310 fprintf (stderr, " Rooted: `%s' at %" ffetargetOffset_f "d\n", 311 ffesymbol_text (rooted_sym), 312 ffestorag_offset (rooted_st)); 313#endif 314 315 /* The offset of this symbol from the equiv's root symbol 316 is already known, and the size of this symbol is already 317 incorporated in the size of the equiv's aggregate area. 318 What we now determine is the offset of this equivalence 319 _list_ from the equiv's root symbol. 320 321 For example, if we know that A is at offset 16 from the 322 root symbol, given EQUIVALENCE (B(24),A(2)), we're looking 323 at A(2), meaning that the offset for this equivalence list 324 is 20 (4 bytes beyond the beginning of A, assuming typical 325 array types, dimensions, and type info). */ 326 327 if (!ffeequiv_offset_ (&eqlist_offset, rooted_sym, rooted_exp, FALSE, 328 ffestorag_offset (rooted_st), FALSE)) 329 330 { /* Can't use this one. */ 331 ffesymbol_set_equiv (rooted_sym, NULL);/* Equiv area slated for 332 death. */ 333 rooted_sym = NULL; 334 continue; /* Something's wrong with eqv expr, try another. */ 335 } 336 337#if FFEEQUIV_DEBUG 338 fprintf (stderr, " Eqlist offset: %" ffetargetOffset_f "d\n", 339 eqlist_offset); 340#endif 341 342 break; 343 } 344 345 /* If no rooted symbol, it means this list has no roots -- yet. 346 So, forget this list this time around, but we'll get back 347 to it after the outer loop iterates at least one more time, 348 and, ultimately, it will have a root. */ 349 350 if (rooted_sym == NULL) 351 { 352#if FFEEQUIV_DEBUG 353 fprintf (stderr, "No roots.\n"); 354#endif 355 continue; 356 } 357 358 /* We now have a rooted symbol/expr and the offset of this equivalence 359 list from the root symbol. The other expressions in this 360 list all identify an initial storage unit that must have the 361 same offset. */ 362 363 for (item = ffebld_head (list); 364 item != NULL; 365 item = ffebld_trail (item)) 366 { /* For every equivalence item in the list */ 367 ffebld item_exp; /* Expression for equivalence. */ 368 ffestorag item_st; /* Storage for var. */ 369 ffesymbol item_sym; /* Var itself. */ 370 ffetargetOffset item_offset; /* Offset for var from root. */ 371 ffetargetOffset new_size; 372 373 item_exp = ffebld_head (item); 374 item_sym = ffeequiv_symbol (item_exp); 375 if ((item_sym == NULL) 376 || (ffesymbol_equiv (item_sym) == NULL)) 377 continue; /* Ignore me. */ 378 379 if (item_sym == rooted_sym) 380 continue; /* Rooted sym already set up. */ 381 382 if (!ffeequiv_offset_ (&item_offset, item_sym, item_exp, TRUE, 383 eqlist_offset, FALSE)) 384 { 385 ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */ 386 continue; 387 } 388 389#if FFEEQUIV_DEBUG 390 fprintf (stderr, " Item `%s' at %" ffetargetOffset_f "d", 391 ffesymbol_text (item_sym), item_offset); 392#endif 393 394 if (ffesymbol_rank (item_sym) == 0) 395 num_elements = 1; 396 else 397 num_elements = ffebld_constant_integerdefault (ffebld_conter 398 (ffesymbol_arraysize (item_sym))); 399 ffetarget_layout (ffesymbol_text (item_sym), &alignment, &modulo, 400 &size, ffesymbol_basictype (item_sym), 401 ffesymbol_kindtype (item_sym), ffesymbol_size (item_sym), 402 num_elements); 403 pad = ffetarget_align (ffestorag_ptr_to_alignment (st), 404 ffestorag_ptr_to_modulo (st), 405 item_offset, alignment, modulo); 406 if (pad != 0) 407 { 408 ffebad_start (FFEBAD_EQUIV_ALIGN); 409 ffebad_string (ffesymbol_text (item_sym)); 410 ffebad_finish (); 411 ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */ 412 continue; 413 } 414 415 /* If the variable's offset is less than the offset for the 416 aggregate storage area, it means it has to expand backwards 417 -- i.e. the new known starting point of the area precedes the 418 old one. This can't happen with COMMON areas (the standard, 419 and common sense, disallow it), but it is normal for local 420 EQUIVALENCE areas. 421 422 Also handle choosing the "documented" rooted symbol for this 423 area here. It's the symbol at the bottom (lowest offset) 424 of the aggregate area, with ties going to the name that would 425 sort to the top of the list of ties. */ 426 427 if (item_offset == ffestorag_offset (st)) 428 { 429 if ((item_sym != ffestorag_symbol (st)) 430 && (strcmp (ffesymbol_text (item_sym), 431 ffesymbol_text (ffestorag_symbol (st))) 432 < 0)) 433 ffestorag_set_symbol (st, item_sym); 434 } 435 else if (item_offset < ffestorag_offset (st)) 436 { 437 /* Increase size of equiv area to start for lower offset 438 relative to root symbol. */ 439 if (! ffetarget_offset_add (&new_size, 440 ffestorag_offset (st) 441 - item_offset, 442 ffestorag_size (st))) 443 ffetarget_offset_overflow (ffesymbol_text (s)); 444 else 445 ffestorag_set_size (st, new_size); 446 447 ffestorag_set_symbol (st, item_sym); 448 ffestorag_set_offset (st, item_offset); 449 450#if FFEEQUIV_DEBUG 451 fprintf (stderr, " [eq offset=%" ffetargetOffset_f 452 "d, size=%" ffetargetOffset_f "d]", 453 item_offset, new_size); 454#endif 455 } 456 457 if ((item_st = ffesymbol_storage (item_sym)) == NULL) 458 { /* Create new ffestorag object, extend equiv 459 area. */ 460#if FFEEQUIV_DEBUG 461 fprintf (stderr, ".\n"); 462#endif 463 new_storage = TRUE; 464 item_st = ffestorag_new (ffestorag_list_equivs (st)); 465 ffestorag_set_parent (item_st, st); /* Initializations 466 happen there. */ 467 ffestorag_set_init (item_st, NULL); 468 ffestorag_set_accretion (item_st, NULL); 469 ffestorag_set_symbol (item_st, item_sym); 470 ffestorag_set_size (item_st, size); 471 ffestorag_set_offset (item_st, item_offset); 472 ffestorag_set_alignment (item_st, alignment); 473 ffestorag_set_modulo (item_st, modulo); 474 ffestorag_set_type (item_st, FFESTORAG_typeEQUIV); 475 ffestorag_set_basictype (item_st, ffesymbol_basictype (item_sym)); 476 ffestorag_set_kindtype (item_st, ffesymbol_kindtype (item_sym)); 477 ffestorag_set_typesymbol (item_st, item_sym); 478 ffestorag_set_is_save (item_st, FALSE); /* Assume FALSE... */ 479 if (ffestorag_is_save (st)) /* ...update TRUE */ 480 ffestorag_update_save (item_st); /* if needed. */ 481 ffestorag_set_is_init (item_st, FALSE); /* Assume FALSE... */ 482 if (ffestorag_is_init (st)) /* ...update TRUE */ 483 ffestorag_update_init (item_st); /* if needed. */ 484 ffesymbol_set_storage (item_sym, item_st); 485 ffesymbol_signal_unreported (item_sym); 486 if (ffesymbol_is_init (item_sym)) 487 init = TRUE; 488 489 /* Determine new size of equiv area, complain if overflow. */ 490 491 if (!ffetarget_offset_add (&size, item_offset, size) 492 || !ffetarget_offset_add (&size, -ffestorag_offset (st), size)) 493 ffetarget_offset_overflow (ffesymbol_text (s)); 494 else if (size > ffestorag_size (st)) 495 ffestorag_set_size (st, size); 496 ffestorag_update (st, item_sym, ffesymbol_basictype (item_sym), 497 ffesymbol_kindtype (item_sym)); 498 } 499 else 500 { 501#if FFEEQUIV_DEBUG 502 fprintf (stderr, " (was %" ffetargetOffset_f "d).\n", 503 ffestorag_offset (item_st)); 504#endif 505 /* Make sure offset agrees with known offset. */ 506 if (item_offset != ffestorag_offset (item_st)) 507 { 508 char io1[40]; 509 char io2[40]; 510 511 sprintf (&io1[0], "%" ffetargetOffset_f "d", item_offset); 512 sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (item_st)); 513 ffebad_start (FFEBAD_EQUIV_MISMATCH); 514 ffebad_string (ffesymbol_text (item_sym)); 515 ffebad_string (ffesymbol_text (root_sym)); 516 ffebad_string (io1); 517 ffebad_string (io2); 518 ffebad_finish (); 519 } 520 } 521 ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */ 522 } /* (For every equivalence item in the list) */ 523 ffebld_set_head (list, NULL); /* Don't do this list again. */ 524 } /* (For every equivalence list in the list of 525 equivs) */ 526 } while (new_storage && need_storage); 527 528 ffesymbol_set_equiv (root_sym, NULL); /* This one has storage now. */ 529 530 ffeequiv_kill (eq); /* Fully processed, no longer needed. */ 531 532 /* If the offset for this storage area is zero (it cannot be positive), 533 that means the alignment/modulo info is already correct. Otherwise, 534 the alignment info is correct, but the modulo info reflects a 535 zero offset, so fix it. */ 536 537 if (ffestorag_offset (st) < 0) 538 { 539 /* Calculate the initial padding necessary to preserve 540 the alignment/modulo requirements for the storage area. 541 These requirements are themselves kept track of in the 542 record for the storage area as a whole, but really pertain 543 to offset 0 of that area, which is where the root symbol 544 was originally placed. 545 546 The goal here is to have the offset and size for the area 547 faithfully reflect the area itself, not extra requirements 548 like alignment. So to meet the alignment requirements, 549 the modulo for the area should be set as if the area had an 550 alignment requirement of alignment/0 and was aligned/padded 551 downward to meet the alignment requirements of the area at 552 offset zero, the amount of padding needed being the desired 553 value for the modulo of the area. */ 554 555 alignment = ffestorag_alignment (st); 556 modulo = ffestorag_modulo (st); 557 558 /* Since we want to move the whole area *down* (lower memory 559 addresses) as required by the alignment/modulo paid, negate 560 the offset to ffetarget_align, which assumes aligning *up* 561 is desired. */ 562 pad = ffetarget_align (&alignment, &modulo, 563 - ffestorag_offset (st), 564 alignment, 0); 565 ffestorag_set_modulo (st, pad); 566 } 567 568 if (init) 569 ffedata_gather (st); /* Gather subordinate inits into one init. */ 570} 571 572/* ffeequiv_offset_ -- Determine offset from start of symbol 573 574 ffetargetOffset offset; 575 ffesymbol s; // Symbol for error reporting. 576 ffebld expr; // opSUBSTR, opARRAYREF, opSYMTER, opANY. 577 bool subtract; // FALSE means add to adjust, TRUE means subtract from it. 578 ffetargetOffset adjust; // Helps keep answer in pos range (unsigned). 579 if (!ffeequiv_offset_(&offset,s,expr,subtract,adjust)) 580 // error doing the calculation, message already printed 581 582 Returns the offset represented by the SUBSTR, ARRAYREF, or SUBSTR/ARRAYREF 583 combination added-to/subtracted-from the adjustment specified. If there 584 is an error of some kind, returns FALSE, else returns TRUE. Note that 585 only the first storage unit specified is considered; A(1:1) and A(1:2000) 586 have the same first storage unit and so return the same offset. */ 587 588static bool 589ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s UNUSED, 590 ffebld expr, bool subtract, ffetargetOffset adjust, 591 bool no_precede) 592{ 593 ffetargetIntegerDefault value = 0; 594 ffetargetOffset cval; /* Converted value. */ 595 ffesymbol sym; 596 597 if (expr == NULL) 598 return FALSE; 599 600again: /* :::::::::::::::::::: */ 601 602 switch (ffebld_op (expr)) 603 { 604 case FFEBLD_opANY: 605 return FALSE; 606 607 case FFEBLD_opSYMTER: 608 { 609 ffetargetOffset size; /* Size of a single unit. */ 610 ffetargetAlign a; /* Ignored. */ 611 ffetargetAlign m; /* Ignored. */ 612 613 sym = ffebld_symter (expr); 614 if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY) 615 return FALSE; 616 617 ffetarget_layout (ffesymbol_text (sym), &a, &m, &size, 618 ffesymbol_basictype (sym), 619 ffesymbol_kindtype (sym), 1, 1); 620 621 if (value < 0) 622 { /* Really invalid, as in A(-2:5), but in case 623 it's wanted.... */ 624 if (!ffetarget_offset (&cval, -value)) 625 return FALSE; 626 627 if (!ffetarget_offset_multiply (&cval, cval, size)) 628 return FALSE; 629 630 if (subtract) 631 return ffetarget_offset_add (offset, cval, adjust); 632 633 if (no_precede && (cval > adjust)) 634 { 635 neg: /* :::::::::::::::::::: */ 636 ffebad_start (FFEBAD_COMMON_NEG); 637 ffebad_string (ffesymbol_text (sym)); 638 ffebad_finish (); 639 return FALSE; 640 } 641 return ffetarget_offset_add (offset, -cval, adjust); 642 } 643 644 if (!ffetarget_offset (&cval, value)) 645 return FALSE; 646 647 if (!ffetarget_offset_multiply (&cval, cval, size)) 648 return FALSE; 649 650 if (!subtract) 651 return ffetarget_offset_add (offset, cval, adjust); 652 653 if (no_precede && (cval > adjust)) 654 goto neg; /* :::::::::::::::::::: */ 655 656 return ffetarget_offset_add (offset, -cval, adjust); 657 } 658 659 case FFEBLD_opARRAYREF: 660 { 661 ffebld symexp = ffebld_left (expr); 662 ffebld subscripts = ffebld_right (expr); 663 ffebld dims; 664 ffetargetIntegerDefault width; 665 ffetargetIntegerDefault arrayval; 666 ffetargetIntegerDefault lowbound; 667 ffetargetIntegerDefault highbound; 668 ffebld subscript; 669 ffebld dim; 670 ffebld low; 671 ffebld high; 672 int rank = 0; 673 674 if (ffebld_op (symexp) != FFEBLD_opSYMTER) 675 return FALSE; 676 677 sym = ffebld_symter (symexp); 678 if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY) 679 return FALSE; 680 681 if (ffesymbol_size (sym) == FFETARGET_charactersizeNONE) 682 width = 1; 683 else 684 width = ffesymbol_size (sym); 685 dims = ffesymbol_dims (sym); 686 687 while (subscripts != NULL) 688 { 689 ++rank; 690 if (dims == NULL) 691 { 692 ffebad_start (FFEBAD_EQUIV_MANY); 693 ffebad_string (ffesymbol_text (sym)); 694 ffebad_finish (); 695 return FALSE; 696 } 697 698 subscript = ffebld_head (subscripts); 699 dim = ffebld_head (dims); 700 701 if (ffebld_op (subscript) == FFEBLD_opANY) 702 return FALSE; 703 704 assert (ffebld_op (subscript) == FFEBLD_opCONTER); 705 assert (ffeinfo_basictype (ffebld_info (subscript)) 706 == FFEINFO_basictypeINTEGER); 707 assert (ffeinfo_kindtype (ffebld_info (subscript)) 708 == FFEINFO_kindtypeINTEGERDEFAULT); 709 arrayval = ffebld_constant_integerdefault (ffebld_conter 710 (subscript)); 711 712 if (ffebld_op (dim) == FFEBLD_opANY) 713 return FALSE; 714 715 assert (ffebld_op (dim) == FFEBLD_opBOUNDS); 716 low = ffebld_left (dim); 717 high = ffebld_right (dim); 718 719 if (low == NULL) 720 lowbound = 1; 721 else 722 { 723 if (ffebld_op (low) == FFEBLD_opANY) 724 return FALSE; 725 726 assert (ffebld_op (low) == FFEBLD_opCONTER); 727 assert (ffeinfo_basictype (ffebld_info (low)) 728 == FFEINFO_basictypeINTEGER); 729 assert (ffeinfo_kindtype (ffebld_info (low)) 730 == FFEINFO_kindtypeINTEGERDEFAULT); 731 lowbound 732 = ffebld_constant_integerdefault (ffebld_conter (low)); 733 } 734 735 if (ffebld_op (high) == FFEBLD_opANY) 736 return FALSE; 737 738 assert (ffebld_op (high) == FFEBLD_opCONTER); 739 assert (ffeinfo_basictype (ffebld_info (high)) 740 == FFEINFO_basictypeINTEGER); 741 assert (ffeinfo_kindtype (ffebld_info (high)) 742 == FFEINFO_kindtypeINTEGER1); 743 highbound 744 = ffebld_constant_integerdefault (ffebld_conter (high)); 745 746 if ((arrayval < lowbound) || (arrayval > highbound)) 747 { 748 char rankstr[10]; 749 750 sprintf (rankstr, "%d", rank); 751 ffebad_start (FFEBAD_EQUIV_SUBSCRIPT); 752 ffebad_string (ffesymbol_text (sym)); 753 ffebad_string (rankstr); 754 ffebad_finish (); 755 } 756 757 subscripts = ffebld_trail (subscripts); 758 dims = ffebld_trail (dims); 759 760 value += width * (arrayval - lowbound); 761 if (subscripts != NULL) 762 width *= highbound - lowbound + 1; 763 } 764 765 if (dims != NULL) 766 { 767 ffebad_start (FFEBAD_EQUIV_FEW); 768 ffebad_string (ffesymbol_text (sym)); 769 ffebad_finish (); 770 return FALSE; 771 } 772 773 expr = symexp; 774 } 775 goto again; /* :::::::::::::::::::: */ 776 777 case FFEBLD_opSUBSTR: 778 { 779 ffebld begin = ffebld_head (ffebld_right (expr)); 780 781 expr = ffebld_left (expr); 782 if (ffebld_op (expr) == FFEBLD_opANY) 783 return FALSE; 784 if (ffebld_op (expr) == FFEBLD_opARRAYREF) 785 sym = ffebld_symter (ffebld_left (expr)); 786 else if (ffebld_op (expr) == FFEBLD_opSYMTER) 787 sym = ffebld_symter (expr); 788 else 789 sym = NULL; 790 791 if ((sym != NULL) 792 && (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)) 793 return FALSE; 794 795 if (begin == NULL) 796 value = 0; 797 else 798 { 799 if (ffebld_op (begin) == FFEBLD_opANY) 800 return FALSE; 801 assert (ffebld_op (begin) == FFEBLD_opCONTER); 802 assert (ffeinfo_basictype (ffebld_info (begin)) 803 == FFEINFO_basictypeINTEGER); 804 assert (ffeinfo_kindtype (ffebld_info (begin)) 805 == FFEINFO_kindtypeINTEGERDEFAULT); 806 807 value = ffebld_constant_integerdefault (ffebld_conter (begin)); 808 809 if ((value < 1) 810 || ((sym != NULL) 811 && (value > ffesymbol_size (sym)))) 812 { 813 ffebad_start (FFEBAD_EQUIV_RANGE); 814 ffebad_string (ffesymbol_text (sym)); 815 ffebad_finish (); 816 } 817 818 --value; 819 } 820 if ((sym != NULL) 821 && (ffesymbol_basictype (sym) != FFEINFO_basictypeCHARACTER)) 822 { 823 ffebad_start (FFEBAD_EQUIV_SUBSTR); 824 ffebad_string (ffesymbol_text (sym)); 825 ffebad_finish (); 826 value = 0; 827 } 828 } 829 goto again; /* :::::::::::::::::::: */ 830 831 default: 832 assert ("bad op" == NULL); 833 return FALSE; 834 } 835 836} 837 838/* ffeequiv_add -- Add list of equivalences to list of lists for eq object 839 840 ffeequiv eq; 841 ffebld list; 842 ffelexToken t; // points to first item in equivalence list 843 ffeequiv_add(eq,list,t); 844 845 Check the list to make sure only one common symbol is involved (even 846 if multiple times) and agrees with the common symbol for the equivalence 847 object (or it has no common symbol until now). Prepend (or append, it 848 doesn't matter) the list to the list of lists for the equivalence object. 849 Otherwise report an error and return. */ 850 851void 852ffeequiv_add (ffeequiv eq, ffebld list, ffelexToken t) 853{ 854 ffebld item; 855 ffesymbol symbol; 856 ffesymbol common = ffeequiv_common (eq); 857 858 for (item = list; item != NULL; item = ffebld_trail (item)) 859 { 860 symbol = ffeequiv_symbol (ffebld_head (item)); 861 862 if (ffesymbol_common (symbol) != NULL) /* Is symbol known in COMMON yet? */ 863 { 864 if (common == NULL) 865 common = ffesymbol_common (symbol); 866 else if (common != ffesymbol_common (symbol)) 867 { 868 /* Yes, and symbol disagrees with others on the COMMON area. */ 869 ffebad_start (FFEBAD_EQUIV_COMMON); 870 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 871 ffebad_string (ffesymbol_text (common)); 872 ffebad_string (ffesymbol_text (ffesymbol_common (symbol))); 873 ffebad_finish (); 874 return; 875 } 876 } 877 } 878 879 if ((common != NULL) 880 && (ffeequiv_common (eq) == NULL)) /* Is COMMON involved already? */ 881 ffeequiv_set_common (eq, common); /* No, but it is now. */ 882 883 for (item = list; item != NULL; item = ffebld_trail (item)) 884 { 885 symbol = ffeequiv_symbol (ffebld_head (item)); 886 887 if (ffesymbol_equiv (symbol) == NULL) 888 ffesymbol_set_equiv (symbol, eq); 889 else 890 assert (ffesymbol_equiv (symbol) == eq); 891 892 if (ffesymbol_common (symbol) == NULL) /* Is symbol in a COMMON 893 area? */ 894 { /* No (at least not yet). */ 895 if (ffesymbol_is_save (symbol)) 896 ffeequiv_update_save (eq); /* EQUIVALENCE has >=1 SAVEd entity. */ 897 if (ffesymbol_is_init (symbol)) 898 ffeequiv_update_init (eq); /* EQUIVALENCE has >=1 init'd entity. */ 899 continue; /* Nothing more to do here. */ 900 } 901 902#if FFEGLOBAL_ENABLED 903 if (ffesymbol_is_init (symbol)) 904 ffeglobal_init_common (ffesymbol_common (symbol), t); 905#endif 906 907 if (ffesymbol_is_save (ffesymbol_common (symbol))) 908 ffeequiv_update_save (eq); /* EQUIVALENCE is in a SAVEd COMMON block. */ 909 if (ffesymbol_is_init (ffesymbol_common (symbol))) 910 ffeequiv_update_init (eq); /* EQUIVALENCE is in a init'd COMMON block. */ 911 } 912 913 ffeequiv_set_list (eq, ffebld_new_item (list, ffeequiv_list (eq))); 914} 915 916/* ffeequiv_dump -- Dump info on equivalence object 917 918 ffeequiv eq; 919 ffeequiv_dump(eq); */ 920 921#if FFECOM_targetCURRENT == FFECOM_targetFFE 922void 923ffeequiv_dump (ffeequiv eq) 924{ 925 if (ffeequiv_common (eq) != NULL) 926 fprintf (dmpout, "(common %s) ", ffesymbol_text (ffeequiv_common (eq))); 927 ffebld_dump (ffeequiv_list (eq)); 928} 929#endif 930 931/* ffeequiv_exec_transition -- Do the hard work on all the equivalence objects 932 933 ffeequiv_exec_transition(); */ 934 935void 936ffeequiv_exec_transition () 937{ 938 while (ffeequiv_list_.first != (ffeequiv) &ffeequiv_list_.first) 939 ffeequiv_layout_local_ (ffeequiv_list_.first); 940} 941 942/* ffeequiv_init_2 -- Initialize for new program unit 943 944 ffeequiv_init_2(); 945 946 Initializes the list of equivalences. */ 947 948void 949ffeequiv_init_2 () 950{ 951 ffeequiv_list_.first = (ffeequiv) &ffeequiv_list_.first; 952 ffeequiv_list_.last = (ffeequiv) &ffeequiv_list_.first; 953} 954 955/* ffeequiv_kill -- Kill equivalence object after removing from list 956 957 ffeequiv eq; 958 ffeequiv_kill(eq); 959 960 Removes equivalence object from master list, then kills it. */ 961 962void 963ffeequiv_kill (ffeequiv victim) 964{ 965 victim->next->previous = victim->previous; 966 victim->previous->next = victim->next; 967 if (ffe_is_do_internal_checks ()) 968 { 969 ffebld list; 970 ffebld item; 971 ffebld expr; 972 973 /* Assert that nobody our victim points to still points to it. */ 974 975 assert ((victim->common == NULL) 976 || (ffesymbol_equiv (victim->common) == NULL)); 977 978 for (list = victim->list; list != NULL; list = ffebld_trail (list)) 979 { 980 for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item)) 981 { 982 ffesymbol sym; 983 984 expr = ffebld_head (item); 985 sym = ffeequiv_symbol (expr); 986 if (sym == NULL) 987 continue; 988 assert (ffesymbol_equiv (sym) != victim); 989 } 990 } 991 } 992 malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim)); 993} 994 995/* ffeequiv_layout_cblock -- Lay out storage for common area 996 997 ffestorag st; 998 if (ffeequiv_layout_cblock(st)) 999 // at least one equiv'd symbol has init/accretion expr. 1000 1001 Now that the explicitly COMMONed variables in the common area (whose 1002 ffestorag object is passed) have been laid out, lay out the storage 1003 for all variables equivalenced into the area by making subordinate 1004 ffestorag objects for them. */ 1005 1006bool 1007ffeequiv_layout_cblock (ffestorag st) 1008{ 1009 ffesymbol s = ffestorag_symbol (st); /* CBLOCK symbol. */ 1010 ffebld list; /* List of explicit common vars, in order, in 1011 s. */ 1012 ffebld item; /* List of list of equivalences in a given 1013 explicit common var. */ 1014 ffebld root; /* Expression for (1st) explicit common var 1015 in list of eqs. */ 1016 ffestorag rst; /* Storage for root. */ 1017 ffetargetOffset root_offset; /* Offset for root into common area. */ 1018 ffesymbol sr; /* Root itself. */ 1019 ffeequiv seq; /* Its equivalence object, if any. */ 1020 ffebld var; /* Expression for equivalence. */ 1021 ffestorag vst; /* Storage for var. */ 1022 ffetargetOffset var_offset; /* Offset for var into common area. */ 1023 ffesymbol sv; /* Var itself. */ 1024 ffebld altroot; /* Alternate root. */ 1025 ffesymbol altrootsym; /* Alternate root symbol. */ 1026 ffetargetAlign alignment; 1027 ffetargetAlign modulo; 1028 ffetargetAlign pad; 1029 ffetargetOffset size; 1030 ffetargetOffset num_elements; 1031 bool new_storage; /* Established new storage info. */ 1032 bool need_storage; /* Have need for more storage info. */ 1033 bool ok; 1034 bool init = FALSE; 1035 1036 assert (st != NULL); 1037 assert (ffestorag_type (st) == FFESTORAG_typeCBLOCK); 1038 assert (ffesymbol_kind (ffestorag_symbol (st)) == FFEINFO_kindCOMMON); 1039 1040 for (list = ffesymbol_commonlist (ffestorag_symbol (st)); 1041 list != NULL; 1042 list = ffebld_trail (list)) 1043 { /* For every variable in the common area */ 1044 assert (ffebld_op (ffebld_head (list)) == FFEBLD_opSYMTER); 1045 sr = ffebld_symter (ffebld_head (list)); 1046 if ((seq = ffesymbol_equiv (sr)) == NULL) 1047 continue; /* No equivalences to process. */ 1048 rst = ffesymbol_storage (sr); 1049 if (rst == NULL) 1050 { 1051 assert (ffesymbol_kind (sr) == FFEINFO_kindANY); 1052 continue; 1053 } 1054 ffesymbol_set_equiv (sr, NULL); /* Cancel ref to equiv obj. */ 1055 do 1056 { 1057 new_storage = FALSE; 1058 need_storage = FALSE; 1059 for (item = ffeequiv_list (seq); /* Get list of equivs. */ 1060 item != NULL; 1061 item = ffebld_trail (item)) 1062 { /* For every eqv list in the list of equivs 1063 for the variable */ 1064 altroot = NULL; 1065 altrootsym = NULL; 1066 for (root = ffebld_head (item); 1067 root != NULL; 1068 root = ffebld_trail (root)) 1069 { /* For every equivalence item in the list */ 1070 sv = ffeequiv_symbol (ffebld_head (root)); 1071 if (sv == sr) 1072 break; /* Found first mention of "rooted" symbol. */ 1073 if (ffesymbol_storage (sv) != NULL) 1074 { 1075 altroot = root; /* If no mention, use this guy 1076 instead. */ 1077 altrootsym = sv; 1078 } 1079 } 1080 if (root != NULL) 1081 { 1082 root = ffebld_head (root); /* Lose its opITEM. */ 1083 ok = ffeequiv_offset_ (&root_offset, sr, root, FALSE, 1084 ffestorag_offset (rst), TRUE); 1085 /* Equiv point prior to start of common area? */ 1086 } 1087 else if (altroot != NULL) 1088 { 1089 /* Equiv point prior to start of common area? */ 1090 root = ffebld_head (altroot); 1091 ok = ffeequiv_offset_ (&root_offset, altrootsym, root, 1092 FALSE, 1093 ffestorag_offset (ffesymbol_storage (altrootsym)), 1094 TRUE); 1095 ffesymbol_set_equiv (altrootsym, NULL); 1096 } 1097 else 1098 /* No rooted symbol in list of equivalences! */ 1099 { /* Assume this was due to opANY and ignore 1100 this list for now. */ 1101 need_storage = TRUE; 1102 continue; 1103 } 1104 1105 /* We now know the root symbol and the operating offset of that 1106 root into the common area. The other expressions in the 1107 list all identify an initial storage unit that must have the 1108 same offset. */ 1109 1110 for (var = ffebld_head (item); 1111 var != NULL; 1112 var = ffebld_trail (var)) 1113 { /* For every equivalence item in the list */ 1114 if (ffebld_head (var) == root) 1115 continue; /* Except root, of course. */ 1116 sv = ffeequiv_symbol (ffebld_head (var)); 1117 if (sv == NULL) 1118 continue; /* Except erroneous stuff (opANY). */ 1119 ffesymbol_set_equiv (sv, NULL); /* Don't need this ref 1120 anymore. */ 1121 if (!ok 1122 || !ffeequiv_offset_ (&var_offset, sv, 1123 ffebld_head (var), TRUE, 1124 root_offset, TRUE)) 1125 continue; /* Can't do negative offset wrt COMMON. */ 1126 1127 if (ffesymbol_rank (sv) == 0) 1128 num_elements = 1; 1129 else 1130 num_elements = ffebld_constant_integerdefault 1131 (ffebld_conter (ffesymbol_arraysize (sv))); 1132 ffetarget_layout (ffesymbol_text (sv), &alignment, 1133 &modulo, &size, 1134 ffesymbol_basictype (sv), 1135 ffesymbol_kindtype (sv), 1136 ffesymbol_size (sv), num_elements); 1137 pad = ffetarget_align (ffestorag_ptr_to_alignment (st), 1138 ffestorag_ptr_to_modulo (st), 1139 var_offset, alignment, modulo); 1140 if (pad != 0) 1141 { 1142 ffebad_start (FFEBAD_EQUIV_ALIGN); 1143 ffebad_string (ffesymbol_text (sv)); 1144 ffebad_finish (); 1145 continue; 1146 } 1147 1148 if ((vst = ffesymbol_storage (sv)) == NULL) 1149 { /* Create new ffestorag object, extend 1150 cblock. */ 1151 new_storage = TRUE; 1152 vst = ffestorag_new (ffestorag_list_equivs (st)); 1153 ffestorag_set_parent (vst, st); /* Initializations 1154 happen there. */ 1155 ffestorag_set_init (vst, NULL); 1156 ffestorag_set_accretion (vst, NULL); 1157 ffestorag_set_symbol (vst, sv); 1158 ffestorag_set_size (vst, size); 1159 ffestorag_set_offset (vst, var_offset); 1160 ffestorag_set_alignment (vst, alignment); 1161 ffestorag_set_modulo (vst, modulo); 1162 ffestorag_set_type (vst, FFESTORAG_typeEQUIV); 1163 ffestorag_set_basictype (vst, ffesymbol_basictype (sv)); 1164 ffestorag_set_kindtype (vst, ffesymbol_kindtype (sv)); 1165 ffestorag_set_typesymbol (vst, sv); 1166 ffestorag_set_is_save (vst, FALSE); /* Assume FALSE... */ 1167 if (ffestorag_is_save (st)) /* ...update TRUE */ 1168 ffestorag_update_save (vst); /* if needed. */ 1169 ffestorag_set_is_init (vst, FALSE); /* Assume FALSE... */ 1170 if (ffestorag_is_init (st)) /* ...update TRUE */ 1171 ffestorag_update_init (vst); /* if needed. */ 1172 if (!ffetarget_offset_add (&size, var_offset, size)) 1173 /* Find one size of common block, complain if 1174 overflow. */ 1175 ffetarget_offset_overflow (ffesymbol_text (s)); 1176 else if (size > ffestorag_size (st)) 1177 /* Extend common. */ 1178 ffestorag_set_size (st, size); 1179 ffesymbol_set_storage (sv, vst); 1180 ffesymbol_set_common (sv, s); 1181 ffesymbol_signal_unreported (sv); 1182 ffestorag_update (st, sv, ffesymbol_basictype (sv), 1183 ffesymbol_kindtype (sv)); 1184 if (ffesymbol_is_init (sv)) 1185 init = TRUE; 1186 } 1187 else 1188 { 1189 /* Make sure offset agrees with known offset. */ 1190 if (var_offset != ffestorag_offset (vst)) 1191 { 1192 char io1[40]; 1193 char io2[40]; 1194 1195 sprintf (&io1[0], "%" ffetargetOffset_f "d", var_offset); 1196 sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (vst)); 1197 ffebad_start (FFEBAD_EQUIV_MISMATCH); 1198 ffebad_string (ffesymbol_text (sv)); 1199 ffebad_string (ffesymbol_text (s)); 1200 ffebad_string (io1); 1201 ffebad_string (io2); 1202 ffebad_finish (); 1203 } 1204 } 1205 } /* (For every equivalence item in the list) */ 1206 } /* (For every eqv list in the list of equivs 1207 for the variable) */ 1208 } 1209 while (new_storage && need_storage); 1210 1211 ffeequiv_kill (seq); /* Kill equiv obj. */ 1212 } /* (For every variable in the common area) */ 1213 1214 return init; 1215} 1216 1217/* ffeequiv_merge -- Merge two equivalence objects, return the merged result 1218 1219 ffeequiv eq1; 1220 ffeequiv eq2; 1221 ffelexToken t; // points to current equivalence item forcing the merge. 1222 eq1 = ffeequiv_merge(eq1,eq2,t); 1223 1224 If the two equivalence objects can be merged, they are, all the 1225 ffesymbols in their lists of lists are adjusted to point to the merged 1226 equivalence object, and the merged object is returned. 1227 1228 Otherwise, the two equivalence objects have different non-NULL common 1229 symbols, so the merge cannot take place. An error message is issued and 1230 NULL is returned. */ 1231 1232ffeequiv 1233ffeequiv_merge (ffeequiv eq1, ffeequiv eq2, ffelexToken t) 1234{ 1235 ffebld list; 1236 ffebld eqs; 1237 ffesymbol symbol; 1238 ffebld last = NULL; 1239 1240 /* If both equivalence objects point to different common-based symbols, 1241 complain. Of course, one or both might have NULL common symbols now, 1242 and get COMMONed later, but the COMMON statement handler checks for 1243 this. */ 1244 1245 if ((ffeequiv_common (eq1) != NULL) && (ffeequiv_common (eq2) != NULL) 1246 && (ffeequiv_common (eq1) != ffeequiv_common (eq2))) 1247 { 1248 ffebad_start (FFEBAD_EQUIV_COMMON); 1249 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 1250 ffebad_string (ffesymbol_text (ffeequiv_common (eq1))); 1251 ffebad_string (ffesymbol_text (ffeequiv_common (eq2))); 1252 ffebad_finish (); 1253 return NULL; 1254 } 1255 1256 /* Make eq1 the new, merged object (arbitrarily). */ 1257 1258 if (ffeequiv_common (eq1) == NULL) 1259 ffeequiv_set_common (eq1, ffeequiv_common (eq2)); 1260 1261 /* If the victim object has any init'ed entities, so does the new object. */ 1262 1263 if (eq2->is_init) 1264 eq1->is_init = TRUE; 1265 1266#if FFEGLOBAL_ENABLED 1267 if (eq1->is_init && (ffeequiv_common (eq1) != NULL)) 1268 ffeglobal_init_common (ffeequiv_common (eq1), t); 1269#endif 1270 1271 /* If the victim object has any SAVEd entities, then the new object has 1272 some. */ 1273 1274 if (ffeequiv_is_save (eq2)) 1275 ffeequiv_update_save (eq1); 1276 1277 /* If the victim object has any init'd entities, then the new object has 1278 some. */ 1279 1280 if (ffeequiv_is_init (eq2)) 1281 ffeequiv_update_init (eq1); 1282 1283 /* Adjust all the symbols in the list of lists of equivalences for the 1284 victim equivalence object so they point to the new merged object 1285 instead. */ 1286 1287 for (list = ffeequiv_list (eq2); list != NULL; list = ffebld_trail (list)) 1288 { 1289 for (eqs = ffebld_head (list); eqs != NULL; eqs = ffebld_trail (eqs)) 1290 { 1291 symbol = ffeequiv_symbol (ffebld_head (eqs)); 1292 if (ffesymbol_equiv (symbol) == eq2) 1293 ffesymbol_set_equiv (symbol, eq1); 1294 else 1295 assert (ffesymbol_equiv (symbol) == eq1); /* Can see a sym > once. */ 1296 } 1297 1298 /* For convenience, remember where the last ITEM in the outer list is. */ 1299 1300 if (ffebld_trail (list) == NULL) 1301 { 1302 last = list; 1303 break; 1304 } 1305 } 1306 1307 /* Append the list of lists in the new, merged object to the list of lists 1308 in the victim object, then use the new combined list in the new merged 1309 object. */ 1310 1311 ffebld_set_trail (last, ffeequiv_list (eq1)); 1312 ffeequiv_set_list (eq1, ffeequiv_list (eq2)); 1313 1314 /* Unlink and kill the victim object. */ 1315 1316 ffeequiv_kill (eq2); 1317 1318 return eq1; /* Return the new merged object. */ 1319} 1320 1321/* ffeequiv_new -- Create new equivalence object, put in list 1322 1323 ffeequiv eq; 1324 eq = ffeequiv_new(); 1325 1326 Creates a new equivalence object and adds it to the list of equivalence 1327 objects. */ 1328 1329ffeequiv 1330ffeequiv_new () 1331{ 1332 ffeequiv eq; 1333 1334 eq = malloc_new_ks (ffe_pool_program_unit (), "ffeequiv", sizeof (*eq)); 1335 eq->next = (ffeequiv) &ffeequiv_list_.first; 1336 eq->previous = ffeequiv_list_.last; 1337 ffeequiv_set_common (eq, NULL); /* No COMMON area yet. */ 1338 ffeequiv_set_list (eq, NULL); /* No list of lists of equivalences yet. */ 1339 ffeequiv_set_is_save (eq, FALSE); 1340 ffeequiv_set_is_init (eq, FALSE); 1341 eq->next->previous = eq; 1342 eq->previous->next = eq; 1343 1344 return eq; 1345} 1346 1347/* ffeequiv_symbol -- Return symbol for equivalence expression 1348 1349 ffesymbol symbol; 1350 ffebld expr; 1351 symbol = ffeequiv_symbol(expr); 1352 1353 Finds the terminal SYMTER in an equivalence expression and returns the 1354 ffesymbol for it. */ 1355 1356ffesymbol 1357ffeequiv_symbol (ffebld expr) 1358{ 1359 assert (expr != NULL); 1360 1361again: /* :::::::::::::::::::: */ 1362 1363 switch (ffebld_op (expr)) 1364 { 1365 case FFEBLD_opARRAYREF: 1366 case FFEBLD_opSUBSTR: 1367 expr = ffebld_left (expr); 1368 goto again; /* :::::::::::::::::::: */ 1369 1370 case FFEBLD_opSYMTER: 1371 return ffebld_symter (expr); 1372 1373 case FFEBLD_opANY: 1374 return NULL; 1375 1376 default: 1377 assert ("bad eq expr" == NULL); 1378 return NULL; 1379 } 1380} 1381 1382/* ffeequiv_update_init -- Update the INIT flag for the area to TRUE 1383 1384 ffeequiv eq; 1385 ffeequiv_update_init(eq); 1386 1387 If the INIT flag for the <eq> object is already set, return. Else, 1388 set it TRUE and call ffe*_update_init for all objects contained in 1389 this one. */ 1390 1391void 1392ffeequiv_update_init (ffeequiv eq) 1393{ 1394 ffebld list; /* Current list in list of lists. */ 1395 ffebld item; /* Current item in current list. */ 1396 ffebld expr; /* Expression in head of current item. */ 1397 1398 if (eq->is_init) 1399 return; 1400 1401 eq->is_init = TRUE; 1402 1403 if ((eq->common != NULL) 1404 && !ffesymbol_is_init (eq->common)) 1405 ffesymbol_update_init (eq->common); /* Shouldn't be needed. */ 1406 1407 for (list = eq->list; list != NULL; list = ffebld_trail (list)) 1408 { 1409 for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item)) 1410 { 1411 expr = ffebld_head (item); 1412 1413 again: /* :::::::::::::::::::: */ 1414 1415 switch (ffebld_op (expr)) 1416 { 1417 case FFEBLD_opANY: 1418 break; 1419 1420 case FFEBLD_opSYMTER: 1421 if (!ffesymbol_is_init (ffebld_symter (expr))) 1422 ffesymbol_update_init (ffebld_symter (expr)); 1423 break; 1424 1425 case FFEBLD_opARRAYREF: 1426 expr = ffebld_left (expr); 1427 goto again; /* :::::::::::::::::::: */ 1428 1429 case FFEBLD_opSUBSTR: 1430 expr = ffebld_left (expr); 1431 goto again; /* :::::::::::::::::::: */ 1432 1433 default: 1434 assert ("bad op for ffeequiv_update_init" == NULL); 1435 break; 1436 } 1437 } 1438 } 1439} 1440 1441/* ffeequiv_update_save -- Update the SAVE flag for the area to TRUE 1442 1443 ffeequiv eq; 1444 ffeequiv_update_save(eq); 1445 1446 If the SAVE flag for the <eq> object is already set, return. Else, 1447 set it TRUE and call ffe*_update_save for all objects contained in 1448 this one. */ 1449 1450void 1451ffeequiv_update_save (ffeequiv eq) 1452{ 1453 ffebld list; /* Current list in list of lists. */ 1454 ffebld item; /* Current item in current list. */ 1455 ffebld expr; /* Expression in head of current item. */ 1456 1457 if (eq->is_save) 1458 return; 1459 1460 eq->is_save = TRUE; 1461 1462 if ((eq->common != NULL) 1463 && !ffesymbol_is_save (eq->common)) 1464 ffesymbol_update_save (eq->common); /* Shouldn't be needed. */ 1465 1466 for (list = eq->list; list != NULL; list = ffebld_trail (list)) 1467 { 1468 for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item)) 1469 { 1470 expr = ffebld_head (item); 1471 1472 again: /* :::::::::::::::::::: */ 1473 1474 switch (ffebld_op (expr)) 1475 { 1476 case FFEBLD_opANY: 1477 break; 1478 1479 case FFEBLD_opSYMTER: 1480 if (!ffesymbol_is_save (ffebld_symter (expr))) 1481 ffesymbol_update_save (ffebld_symter (expr)); 1482 break; 1483 1484 case FFEBLD_opARRAYREF: 1485 expr = ffebld_left (expr); 1486 goto again; /* :::::::::::::::::::: */ 1487 1488 case FFEBLD_opSUBSTR: 1489 expr = ffebld_left (expr); 1490 goto again; /* :::::::::::::::::::: */ 1491 1492 default: 1493 assert ("bad op for ffeequiv_update_save" == NULL); 1494 break; 1495 } 1496 } 1497 } 1498} 1499