00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028
00029
00030
00031 #define FFEEQUIV_DEBUG 0
00032
00033
00034
00035 #include "proj.h"
00036 #include "equiv.h"
00037 #include "bad.h"
00038 #include "bld.h"
00039 #include "com.h"
00040 #include "data.h"
00041 #include "global.h"
00042 #include "lex.h"
00043 #include "malloc.h"
00044 #include "symbol.h"
00045
00046
00047
00048
00049
00050
00051
00052
00053
00054
00055
00056
00057
00058
00059
00060 struct _ffeequiv_list_
00061 {
00062 ffeequiv first;
00063 ffeequiv last;
00064 };
00065
00066
00067
00068 static struct _ffeequiv_list_ ffeequiv_list_;
00069
00070
00071
00072 static void ffeequiv_destroy_ (ffeequiv eq);
00073 static void ffeequiv_layout_local_ (ffeequiv eq);
00074 static bool ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s,
00075 ffebld expr, bool subtract,
00076 ffetargetOffset adjust, bool no_precede);
00077
00078
00079
00080
00081 static void
00082 ffeequiv_destroy_ (ffeequiv victim)
00083 {
00084 ffebld list;
00085 ffebld item;
00086 ffebld expr;
00087
00088 for (list = victim->list; list != NULL; list = ffebld_trail (list))
00089 {
00090 for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
00091 {
00092 ffesymbol sym;
00093
00094 expr = ffebld_head (item);
00095 sym = ffeequiv_symbol (expr);
00096 if (sym == NULL)
00097 continue;
00098 if (ffesymbol_equiv (sym) != NULL)
00099 ffesymbol_set_equiv (sym, NULL);
00100 }
00101 }
00102 ffeequiv_kill (victim);
00103 }
00104
00105
00106
00107
00108
00109
00110
00111
00112
00113
00114
00115
00116
00117
00118 static void
00119 ffeequiv_layout_local_ (ffeequiv eq)
00120 {
00121 ffestorag st;
00122 ffebld list;
00123 ffebld item;
00124 ffebld root_exp;
00125 ffestorag root_st;
00126 ffesymbol root_sym;
00127 ffebld rooted_exp;
00128 ffestorag rooted_st;
00129 ffesymbol rooted_sym;
00130 ffetargetOffset eqlist_offset;
00131 ffetargetAlign alignment;
00132 ffetargetAlign modulo;
00133 ffetargetAlign pad;
00134 ffetargetOffset size;
00135 ffetargetOffset num_elements;
00136 bool new_storage;
00137 bool need_storage;
00138 bool init;
00139
00140 assert (eq != NULL);
00141
00142 if (ffeequiv_common (eq) != NULL)
00143 {
00144 ffeequiv_destroy_ (eq);
00145 return;
00146 }
00147
00148
00149
00150
00151
00152 #if FFEEQUIV_DEBUG
00153 fprintf (stderr, "Equiv1:\n");
00154 #endif
00155
00156 root_sym = NULL;
00157 root_exp = NULL;
00158
00159 for (list = ffeequiv_list (eq);
00160 list != NULL;
00161 list = ffebld_trail (list))
00162 {
00163
00164 for (item = ffebld_head (list);
00165 item != NULL;
00166 item = ffebld_trail (item))
00167 {
00168 ffetargetOffset ign;
00169
00170 root_exp = ffebld_head (item);
00171 root_sym = ffeequiv_symbol (root_exp);
00172 if (root_sym == NULL)
00173 continue;
00174
00175 assert (ffesymbol_storage (root_sym) == NULL);
00176
00177 if (!ffeequiv_offset_ (&ign, root_sym, root_exp, FALSE, 0, FALSE))
00178 {
00179
00180
00181
00182
00183
00184 ffeequiv_destroy_ (eq);
00185 return;
00186 }
00187
00188 break;
00189 }
00190 if (root_sym != NULL)
00191 break;
00192 }
00193
00194 if (root_sym == NULL)
00195 {
00196 ffeequiv_destroy_ (eq);
00197 return;
00198 }
00199
00200
00201 #if FFEEQUIV_DEBUG
00202 fprintf (stderr, " Root: `%s'\n", ffesymbol_text (root_sym));
00203 #endif
00204
00205
00206
00207
00208 st = ffestorag_new (ffestorag_list_master ());
00209 ffestorag_set_parent (st, NULL);
00210 ffestorag_set_init (st, NULL);
00211 ffestorag_set_accretion (st, NULL);
00212 ffestorag_set_offset (st, 0);
00213 ffestorag_set_alignment (st, 1);
00214 ffestorag_set_modulo (st, 0);
00215 ffestorag_set_type (st, FFESTORAG_typeLOCAL);
00216 ffestorag_set_basictype (st, ffesymbol_basictype (root_sym));
00217 ffestorag_set_kindtype (st, ffesymbol_kindtype (root_sym));
00218 ffestorag_set_typesymbol (st, root_sym);
00219 ffestorag_set_is_save (st, ffeequiv_is_save (eq));
00220 if (ffesymbol_is_save (root_sym))
00221 ffestorag_update_save (st);
00222 ffestorag_set_is_init (st, ffeequiv_is_init (eq));
00223 if (ffesymbol_is_init (root_sym))
00224 ffestorag_update_init (st);
00225 ffestorag_set_symbol (st, root_sym);
00226
00227
00228
00229
00230
00231
00232 if (ffesymbol_rank (root_sym) == 0)
00233 num_elements = 1;
00234 else
00235 num_elements = ffebld_constant_integerdefault (ffebld_conter
00236 (ffesymbol_arraysize (root_sym)));
00237 ffetarget_layout (ffesymbol_text (root_sym), &alignment, &modulo, &size,
00238 ffesymbol_basictype (root_sym), ffesymbol_kindtype (root_sym),
00239 ffesymbol_size (root_sym), num_elements);
00240 ffestorag_set_size (st, size);
00241
00242 pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
00243 ffestorag_ptr_to_modulo (st), 0, alignment,
00244 modulo);
00245 assert (pad == 0);
00246
00247 root_st = ffestorag_new (ffestorag_list_equivs (st));
00248 ffestorag_set_parent (root_st, st);
00249 ffestorag_set_init (root_st, NULL);
00250 ffestorag_set_accretion (root_st, NULL);
00251 ffestorag_set_symbol (root_st, root_sym);
00252 ffestorag_set_size (root_st, size);
00253 ffestorag_set_offset (root_st, 0);
00254 ffestorag_set_alignment (root_st, alignment);
00255 ffestorag_set_modulo (root_st, modulo);
00256 ffestorag_set_type (root_st, FFESTORAG_typeEQUIV);
00257 ffestorag_set_basictype (root_st, ffesymbol_basictype (root_sym));
00258 ffestorag_set_kindtype (root_st, ffesymbol_kindtype (root_sym));
00259 ffestorag_set_typesymbol (root_st, root_sym);
00260 ffestorag_set_is_save (root_st, FALSE);
00261 if (ffestorag_is_save (st))
00262 ffestorag_update_save (root_st);
00263 ffestorag_set_is_init (root_st, FALSE);
00264 if (ffestorag_is_init (st))
00265 ffestorag_update_init (root_st);
00266 ffesymbol_set_storage (root_sym, root_st);
00267 ffesymbol_signal_unreported (root_sym);
00268 init = ffesymbol_is_init (root_sym);
00269
00270
00271
00272
00273
00274 do
00275 {
00276 new_storage = FALSE;
00277 need_storage = FALSE;
00278 for (list = ffeequiv_list (eq);
00279 list != NULL;
00280 list = ffebld_trail (list))
00281 {
00282
00283
00284
00285
00286
00287
00288
00289 rooted_sym = NULL;
00290 rooted_exp = NULL;
00291 eqlist_offset = 0;
00292
00293 for (item = ffebld_head (list);
00294 item != NULL;
00295 item = ffebld_trail (item))
00296 {
00297 rooted_exp = ffebld_head (item);
00298 rooted_sym = ffeequiv_symbol (rooted_exp);
00299 if ((rooted_sym == NULL)
00300 || ((rooted_st = ffesymbol_storage (rooted_sym)) == NULL))
00301 {
00302 rooted_sym = NULL;
00303 continue;
00304 }
00305
00306 need_storage = TRUE;
00307
00308
00309 #if FFEEQUIV_DEBUG
00310 fprintf (stderr, " Rooted: `%s' at %" ffetargetOffset_f "d\n",
00311 ffesymbol_text (rooted_sym),
00312 ffestorag_offset (rooted_st));
00313 #endif
00314
00315
00316
00317
00318
00319
00320
00321
00322
00323
00324
00325
00326
00327 if (!ffeequiv_offset_ (&eqlist_offset, rooted_sym, rooted_exp, FALSE,
00328 ffestorag_offset (rooted_st), FALSE))
00329
00330 {
00331 ffesymbol_set_equiv (rooted_sym, NULL);
00332
00333 rooted_sym = NULL;
00334 continue;
00335 }
00336
00337 #if FFEEQUIV_DEBUG
00338 fprintf (stderr, " Eqlist offset: %" ffetargetOffset_f "d\n",
00339 eqlist_offset);
00340 #endif
00341
00342 break;
00343 }
00344
00345
00346
00347
00348
00349
00350 if (rooted_sym == NULL)
00351 {
00352 #if FFEEQUIV_DEBUG
00353 fprintf (stderr, "No roots.\n");
00354 #endif
00355 continue;
00356 }
00357
00358
00359
00360
00361
00362
00363 for (item = ffebld_head (list);
00364 item != NULL;
00365 item = ffebld_trail (item))
00366 {
00367 ffebld item_exp;
00368 ffestorag item_st;
00369 ffesymbol item_sym;
00370 ffetargetOffset item_offset;
00371 ffetargetOffset new_size;
00372
00373 item_exp = ffebld_head (item);
00374 item_sym = ffeequiv_symbol (item_exp);
00375 if ((item_sym == NULL)
00376 || (ffesymbol_equiv (item_sym) == NULL))
00377 continue;
00378
00379 if (item_sym == rooted_sym)
00380 continue;
00381
00382 if (!ffeequiv_offset_ (&item_offset, item_sym, item_exp, TRUE,
00383 eqlist_offset, FALSE))
00384 {
00385 ffesymbol_set_equiv (item_sym, NULL);
00386 continue;
00387 }
00388
00389 #if FFEEQUIV_DEBUG
00390 fprintf (stderr, " Item `%s' at %" ffetargetOffset_f "d",
00391 ffesymbol_text (item_sym), item_offset);
00392 #endif
00393
00394 if (ffesymbol_rank (item_sym) == 0)
00395 num_elements = 1;
00396 else
00397 num_elements = ffebld_constant_integerdefault (ffebld_conter
00398 (ffesymbol_arraysize (item_sym)));
00399 ffetarget_layout (ffesymbol_text (item_sym), &alignment, &modulo,
00400 &size, ffesymbol_basictype (item_sym),
00401 ffesymbol_kindtype (item_sym), ffesymbol_size (item_sym),
00402 num_elements);
00403 pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
00404 ffestorag_ptr_to_modulo (st),
00405 item_offset, alignment, modulo);
00406 if (pad != 0)
00407 {
00408 ffebad_start (FFEBAD_EQUIV_ALIGN);
00409 ffebad_string (ffesymbol_text (item_sym));
00410 ffebad_finish ();
00411 ffesymbol_set_equiv (item_sym, NULL);
00412 continue;
00413 }
00414
00415
00416
00417
00418
00419
00420
00421
00422
00423
00424
00425
00426
00427 if (item_offset == ffestorag_offset (st))
00428 {
00429 if ((item_sym != ffestorag_symbol (st))
00430 && (strcmp (ffesymbol_text (item_sym),
00431 ffesymbol_text (ffestorag_symbol (st)))
00432 < 0))
00433 ffestorag_set_symbol (st, item_sym);
00434 }
00435 else if (item_offset < ffestorag_offset (st))
00436 {
00437
00438
00439 if (! ffetarget_offset_add (&new_size,
00440 ffestorag_offset (st)
00441 - item_offset,
00442 ffestorag_size (st)))
00443 ffetarget_offset_overflow (ffesymbol_text (s));
00444 else
00445 ffestorag_set_size (st, new_size);
00446
00447 ffestorag_set_symbol (st, item_sym);
00448 ffestorag_set_offset (st, item_offset);
00449
00450 #if FFEEQUIV_DEBUG
00451 fprintf (stderr, " [eq offset=%" ffetargetOffset_f
00452 "d, size=%" ffetargetOffset_f "d]",
00453 item_offset, new_size);
00454 #endif
00455 }
00456
00457 if ((item_st = ffesymbol_storage (item_sym)) == NULL)
00458 {
00459
00460 #if FFEEQUIV_DEBUG
00461 fprintf (stderr, ".\n");
00462 #endif
00463 new_storage = TRUE;
00464 item_st = ffestorag_new (ffestorag_list_equivs (st));
00465 ffestorag_set_parent (item_st, st);
00466
00467 ffestorag_set_init (item_st, NULL);
00468 ffestorag_set_accretion (item_st, NULL);
00469 ffestorag_set_symbol (item_st, item_sym);
00470 ffestorag_set_size (item_st, size);
00471 ffestorag_set_offset (item_st, item_offset);
00472 ffestorag_set_alignment (item_st, alignment);
00473 ffestorag_set_modulo (item_st, modulo);
00474 ffestorag_set_type (item_st, FFESTORAG_typeEQUIV);
00475 ffestorag_set_basictype (item_st, ffesymbol_basictype (item_sym));
00476 ffestorag_set_kindtype (item_st, ffesymbol_kindtype (item_sym));
00477 ffestorag_set_typesymbol (item_st, item_sym);
00478 ffestorag_set_is_save (item_st, FALSE);
00479 if (ffestorag_is_save (st))
00480 ffestorag_update_save (item_st);
00481 ffestorag_set_is_init (item_st, FALSE);
00482 if (ffestorag_is_init (st))
00483 ffestorag_update_init (item_st);
00484 ffesymbol_set_storage (item_sym, item_st);
00485 ffesymbol_signal_unreported (item_sym);
00486 if (ffesymbol_is_init (item_sym))
00487 init = TRUE;
00488
00489
00490
00491 if (!ffetarget_offset_add (&size, item_offset, size)
00492 || !ffetarget_offset_add (&size, -ffestorag_offset (st), size))
00493 ffetarget_offset_overflow (ffesymbol_text (s));
00494 else if (size > ffestorag_size (st))
00495 ffestorag_set_size (st, size);
00496 ffestorag_update (st, item_sym, ffesymbol_basictype (item_sym),
00497 ffesymbol_kindtype (item_sym));
00498 }
00499 else
00500 {
00501 #if FFEEQUIV_DEBUG
00502 fprintf (stderr, " (was %" ffetargetOffset_f "d).\n",
00503 ffestorag_offset (item_st));
00504 #endif
00505
00506 if (item_offset != ffestorag_offset (item_st))
00507 {
00508 char io1[40];
00509 char io2[40];
00510
00511 sprintf (&io1[0], "%" ffetargetOffset_f "d", item_offset);
00512 sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (item_st));
00513 ffebad_start (FFEBAD_EQUIV_MISMATCH);
00514 ffebad_string (ffesymbol_text (item_sym));
00515 ffebad_string (ffesymbol_text (root_sym));
00516 ffebad_string (io1);
00517 ffebad_string (io2);
00518 ffebad_finish ();
00519 }
00520 }
00521 ffesymbol_set_equiv (item_sym, NULL);
00522 }
00523 ffebld_set_head (list, NULL);
00524 }
00525
00526 } while (new_storage && need_storage);
00527
00528 ffesymbol_set_equiv (root_sym, NULL);
00529
00530 ffeequiv_kill (eq);
00531
00532
00533
00534
00535
00536
00537 if (ffestorag_offset (st) < 0)
00538 {
00539
00540
00541
00542
00543
00544
00545
00546
00547
00548
00549
00550
00551
00552
00553
00554
00555 alignment = ffestorag_alignment (st);
00556 modulo = ffestorag_modulo (st);
00557
00558
00559
00560
00561
00562 pad = ffetarget_align (&alignment, &modulo,
00563 - ffestorag_offset (st),
00564 alignment, 0);
00565 ffestorag_set_modulo (st, pad);
00566 }
00567
00568 if (init)
00569 ffedata_gather (st);
00570 }
00571
00572
00573
00574
00575
00576
00577
00578
00579
00580
00581
00582
00583
00584
00585
00586
00587
00588 static bool
00589 ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s UNUSED,
00590 ffebld expr, bool subtract, ffetargetOffset adjust,
00591 bool no_precede)
00592 {
00593 ffetargetIntegerDefault value = 0;
00594 ffetargetOffset cval;
00595 ffesymbol sym;
00596
00597 if (expr == NULL)
00598 return FALSE;
00599
00600 again:
00601
00602 switch (ffebld_op (expr))
00603 {
00604 case FFEBLD_opANY:
00605 return FALSE;
00606
00607 case FFEBLD_opSYMTER:
00608 {
00609 ffetargetOffset size;
00610 ffetargetAlign a;
00611 ffetargetAlign m;
00612
00613 sym = ffebld_symter (expr);
00614 if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)
00615 return FALSE;
00616
00617 ffetarget_layout (ffesymbol_text (sym), &a, &m, &size,
00618 ffesymbol_basictype (sym),
00619 ffesymbol_kindtype (sym), 1, 1);
00620
00621 if (value < 0)
00622 {
00623
00624 if (!ffetarget_offset (&cval, -value))
00625 return FALSE;
00626
00627 if (!ffetarget_offset_multiply (&cval, cval, size))
00628 return FALSE;
00629
00630 if (subtract)
00631 return ffetarget_offset_add (offset, cval, adjust);
00632
00633 if (no_precede && (cval > adjust))
00634 {
00635 neg:
00636 ffebad_start (FFEBAD_COMMON_NEG);
00637 ffebad_string (ffesymbol_text (sym));
00638 ffebad_finish ();
00639 return FALSE;
00640 }
00641 return ffetarget_offset_add (offset, -cval, adjust);
00642 }
00643
00644 if (!ffetarget_offset (&cval, value))
00645 return FALSE;
00646
00647 if (!ffetarget_offset_multiply (&cval, cval, size))
00648 return FALSE;
00649
00650 if (!subtract)
00651 return ffetarget_offset_add (offset, cval, adjust);
00652
00653 if (no_precede && (cval > adjust))
00654 goto neg;
00655
00656 return ffetarget_offset_add (offset, -cval, adjust);
00657 }
00658
00659 case FFEBLD_opARRAYREF:
00660 {
00661 ffebld symexp = ffebld_left (expr);
00662 ffebld subscripts = ffebld_right (expr);
00663 ffebld dims;
00664 ffetargetIntegerDefault width;
00665 ffetargetIntegerDefault arrayval;
00666 ffetargetIntegerDefault lowbound;
00667 ffetargetIntegerDefault highbound;
00668 ffebld subscript;
00669 ffebld dim;
00670 ffebld low;
00671 ffebld high;
00672 int rank = 0;
00673
00674 if (ffebld_op (symexp) != FFEBLD_opSYMTER)
00675 return FALSE;
00676
00677 sym = ffebld_symter (symexp);
00678 if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)
00679 return FALSE;
00680
00681 if (ffesymbol_size (sym) == FFETARGET_charactersizeNONE)
00682 width = 1;
00683 else
00684 width = ffesymbol_size (sym);
00685 dims = ffesymbol_dims (sym);
00686
00687 while (subscripts != NULL)
00688 {
00689 ++rank;
00690 if (dims == NULL)
00691 {
00692 ffebad_start (FFEBAD_EQUIV_MANY);
00693 ffebad_string (ffesymbol_text (sym));
00694 ffebad_finish ();
00695 return FALSE;
00696 }
00697
00698 subscript = ffebld_head (subscripts);
00699 dim = ffebld_head (dims);
00700
00701 if (ffebld_op (subscript) == FFEBLD_opANY)
00702 return FALSE;
00703
00704 assert (ffebld_op (subscript) == FFEBLD_opCONTER);
00705 assert (ffeinfo_basictype (ffebld_info (subscript))
00706 == FFEINFO_basictypeINTEGER);
00707 assert (ffeinfo_kindtype (ffebld_info (subscript))
00708 == FFEINFO_kindtypeINTEGERDEFAULT);
00709 arrayval = ffebld_constant_integerdefault (ffebld_conter
00710 (subscript));
00711
00712 if (ffebld_op (dim) == FFEBLD_opANY)
00713 return FALSE;
00714
00715 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
00716 low = ffebld_left (dim);
00717 high = ffebld_right (dim);
00718
00719 if (low == NULL)
00720 lowbound = 1;
00721 else
00722 {
00723 if (ffebld_op (low) == FFEBLD_opANY)
00724 return FALSE;
00725
00726 assert (ffebld_op (low) == FFEBLD_opCONTER);
00727 assert (ffeinfo_basictype (ffebld_info (low))
00728 == FFEINFO_basictypeINTEGER);
00729 assert (ffeinfo_kindtype (ffebld_info (low))
00730 == FFEINFO_kindtypeINTEGERDEFAULT);
00731 lowbound
00732 = ffebld_constant_integerdefault (ffebld_conter (low));
00733 }
00734
00735 if (ffebld_op (high) == FFEBLD_opANY)
00736 return FALSE;
00737
00738 assert (ffebld_op (high) == FFEBLD_opCONTER);
00739 assert (ffeinfo_basictype (ffebld_info (high))
00740 == FFEINFO_basictypeINTEGER);
00741 assert (ffeinfo_kindtype (ffebld_info (high))
00742 == FFEINFO_kindtypeINTEGER1);
00743 highbound
00744 = ffebld_constant_integerdefault (ffebld_conter (high));
00745
00746 if ((arrayval < lowbound) || (arrayval > highbound))
00747 {
00748 char rankstr[10];
00749
00750 sprintf (rankstr, "%d", rank);
00751 ffebad_start (FFEBAD_EQUIV_SUBSCRIPT);
00752 ffebad_string (ffesymbol_text (sym));
00753 ffebad_string (rankstr);
00754 ffebad_finish ();
00755 }
00756
00757 subscripts = ffebld_trail (subscripts);
00758 dims = ffebld_trail (dims);
00759
00760 value += width * (arrayval - lowbound);
00761 if (subscripts != NULL)
00762 width *= highbound - lowbound + 1;
00763 }
00764
00765 if (dims != NULL)
00766 {
00767 ffebad_start (FFEBAD_EQUIV_FEW);
00768 ffebad_string (ffesymbol_text (sym));
00769 ffebad_finish ();
00770 return FALSE;
00771 }
00772
00773 expr = symexp;
00774 }
00775 goto again;
00776
00777 case FFEBLD_opSUBSTR:
00778 {
00779 ffebld begin = ffebld_head (ffebld_right (expr));
00780
00781 expr = ffebld_left (expr);
00782 if (ffebld_op (expr) == FFEBLD_opANY)
00783 return FALSE;
00784 if (ffebld_op (expr) == FFEBLD_opARRAYREF)
00785 sym = ffebld_symter (ffebld_left (expr));
00786 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
00787 sym = ffebld_symter (expr);
00788 else
00789 sym = NULL;
00790
00791 if ((sym != NULL)
00792 && (ffesymbol_basictype (sym) == FFEINFO_basictypeANY))
00793 return FALSE;
00794
00795 if (begin == NULL)
00796 value = 0;
00797 else
00798 {
00799 if (ffebld_op (begin) == FFEBLD_opANY)
00800 return FALSE;
00801 assert (ffebld_op (begin) == FFEBLD_opCONTER);
00802 assert (ffeinfo_basictype (ffebld_info (begin))
00803 == FFEINFO_basictypeINTEGER);
00804 assert (ffeinfo_kindtype (ffebld_info (begin))
00805 == FFEINFO_kindtypeINTEGERDEFAULT);
00806
00807 value = ffebld_constant_integerdefault (ffebld_conter (begin));
00808
00809 if ((value < 1)
00810 || ((sym != NULL)
00811 && (value > ffesymbol_size (sym))))
00812 {
00813 ffebad_start (FFEBAD_EQUIV_RANGE);
00814 ffebad_string (ffesymbol_text (sym));
00815 ffebad_finish ();
00816 }
00817
00818 --value;
00819 }
00820 if ((sym != NULL)
00821 && (ffesymbol_basictype (sym) != FFEINFO_basictypeCHARACTER))
00822 {
00823 ffebad_start (FFEBAD_EQUIV_SUBSTR);
00824 ffebad_string (ffesymbol_text (sym));
00825 ffebad_finish ();
00826 value = 0;
00827 }
00828 }
00829 goto again;
00830
00831 default:
00832 assert ("bad op" == NULL);
00833 return FALSE;
00834 }
00835
00836 }
00837
00838
00839
00840
00841
00842
00843
00844
00845
00846
00847
00848
00849
00850
00851 void
00852 ffeequiv_add (ffeequiv eq, ffebld list, ffelexToken t)
00853 {
00854 ffebld item;
00855 ffesymbol symbol;
00856 ffesymbol common = ffeequiv_common (eq);
00857
00858 for (item = list; item != NULL; item = ffebld_trail (item))
00859 {
00860 symbol = ffeequiv_symbol (ffebld_head (item));
00861
00862 if (ffesymbol_common (symbol) != NULL)
00863 {
00864 if (common == NULL)
00865 common = ffesymbol_common (symbol);
00866 else if (common != ffesymbol_common (symbol))
00867 {
00868
00869 ffebad_start (FFEBAD_EQUIV_COMMON);
00870 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
00871 ffebad_string (ffesymbol_text (common));
00872 ffebad_string (ffesymbol_text (ffesymbol_common (symbol)));
00873 ffebad_finish ();
00874 return;
00875 }
00876 }
00877 }
00878
00879 if ((common != NULL)
00880 && (ffeequiv_common (eq) == NULL))
00881 ffeequiv_set_common (eq, common);
00882
00883 for (item = list; item != NULL; item = ffebld_trail (item))
00884 {
00885 symbol = ffeequiv_symbol (ffebld_head (item));
00886
00887 if (ffesymbol_equiv (symbol) == NULL)
00888 ffesymbol_set_equiv (symbol, eq);
00889 else
00890 assert (ffesymbol_equiv (symbol) == eq);
00891
00892 if (ffesymbol_common (symbol) == NULL)
00893
00894 {
00895 if (ffesymbol_is_save (symbol))
00896 ffeequiv_update_save (eq);
00897 if (ffesymbol_is_init (symbol))
00898 ffeequiv_update_init (eq);
00899 continue;
00900 }
00901
00902 #if FFEGLOBAL_ENABLED
00903 if (ffesymbol_is_init (symbol))
00904 ffeglobal_init_common (ffesymbol_common (symbol), t);
00905 #endif
00906
00907 if (ffesymbol_is_save (ffesymbol_common (symbol)))
00908 ffeequiv_update_save (eq);
00909 if (ffesymbol_is_init (ffesymbol_common (symbol)))
00910 ffeequiv_update_init (eq);
00911 }
00912
00913 ffeequiv_set_list (eq, ffebld_new_item (list, ffeequiv_list (eq)));
00914 }
00915
00916
00917
00918
00919
00920 void
00921 ffeequiv_exec_transition ()
00922 {
00923 while (ffeequiv_list_.first != (ffeequiv) &ffeequiv_list_.first)
00924 ffeequiv_layout_local_ (ffeequiv_list_.first);
00925 }
00926
00927
00928
00929
00930
00931
00932
00933 void
00934 ffeequiv_init_2 ()
00935 {
00936 ffeequiv_list_.first = (ffeequiv) &ffeequiv_list_.first;
00937 ffeequiv_list_.last = (ffeequiv) &ffeequiv_list_.first;
00938 }
00939
00940
00941
00942
00943
00944
00945
00946
00947 void
00948 ffeequiv_kill (ffeequiv victim)
00949 {
00950 victim->next->previous = victim->previous;
00951 victim->previous->next = victim->next;
00952 if (ffe_is_do_internal_checks ())
00953 {
00954 ffebld list;
00955 ffebld item;
00956 ffebld expr;
00957
00958
00959
00960 assert ((victim->common == NULL)
00961 || (ffesymbol_equiv (victim->common) == NULL));
00962
00963 for (list = victim->list; list != NULL; list = ffebld_trail (list))
00964 {
00965 for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
00966 {
00967 ffesymbol sym;
00968
00969 expr = ffebld_head (item);
00970 sym = ffeequiv_symbol (expr);
00971 if (sym == NULL)
00972 continue;
00973 assert (ffesymbol_equiv (sym) != victim);
00974 }
00975 }
00976 }
00977 malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim));
00978 }
00979
00980
00981
00982
00983
00984
00985
00986
00987
00988
00989
00990
00991 bool
00992 ffeequiv_layout_cblock (ffestorag st)
00993 {
00994 ffesymbol s = ffestorag_symbol (st);
00995 ffebld list;
00996
00997 ffebld item;
00998
00999 ffebld root;
01000
01001 ffestorag rst;
01002 ffetargetOffset root_offset;
01003 ffesymbol sr;
01004 ffeequiv seq;
01005 ffebld var;
01006 ffestorag vst;
01007 ffetargetOffset var_offset;
01008 ffesymbol sv;
01009 ffebld altroot;
01010 ffesymbol altrootsym;
01011 ffetargetAlign alignment;
01012 ffetargetAlign modulo;
01013 ffetargetAlign pad;
01014 ffetargetOffset size;
01015 ffetargetOffset num_elements;
01016 bool new_storage;
01017 bool need_storage;
01018 bool ok;
01019 bool init = FALSE;
01020
01021 assert (st != NULL);
01022 assert (ffestorag_type (st) == FFESTORAG_typeCBLOCK);
01023 assert (ffesymbol_kind (ffestorag_symbol (st)) == FFEINFO_kindCOMMON);
01024
01025 for (list = ffesymbol_commonlist (ffestorag_symbol (st));
01026 list != NULL;
01027 list = ffebld_trail (list))
01028 {
01029 assert (ffebld_op (ffebld_head (list)) == FFEBLD_opSYMTER);
01030 sr = ffebld_symter (ffebld_head (list));
01031 if ((seq = ffesymbol_equiv (sr)) == NULL)
01032 continue;
01033 rst = ffesymbol_storage (sr);
01034 if (rst == NULL)
01035 {
01036 assert (ffesymbol_kind (sr) == FFEINFO_kindANY);
01037 continue;
01038 }
01039 ffesymbol_set_equiv (sr, NULL);
01040 do
01041 {
01042 new_storage = FALSE;
01043 need_storage = FALSE;
01044 for (item = ffeequiv_list (seq);
01045 item != NULL;
01046 item = ffebld_trail (item))
01047 {
01048
01049 altroot = NULL;
01050 altrootsym = NULL;
01051 for (root = ffebld_head (item);
01052 root != NULL;
01053 root = ffebld_trail (root))
01054 {
01055 sv = ffeequiv_symbol (ffebld_head (root));
01056 if (sv == sr)
01057 break;
01058 if (ffesymbol_storage (sv) != NULL)
01059 {
01060 altroot = root;
01061
01062 altrootsym = sv;
01063 }
01064 }
01065 if (root != NULL)
01066 {
01067 root = ffebld_head (root);
01068 ok = ffeequiv_offset_ (&root_offset, sr, root, FALSE,
01069 ffestorag_offset (rst), TRUE);
01070
01071 }
01072 else if (altroot != NULL)
01073 {
01074
01075 root = ffebld_head (altroot);
01076 ok = ffeequiv_offset_ (&root_offset, altrootsym, root,
01077 FALSE,
01078 ffestorag_offset (ffesymbol_storage (altrootsym)),
01079 TRUE);
01080 ffesymbol_set_equiv (altrootsym, NULL);
01081 }
01082 else
01083
01084 {
01085
01086 need_storage = TRUE;
01087 continue;
01088 }
01089
01090
01091
01092
01093
01094
01095 for (var = ffebld_head (item);
01096 var != NULL;
01097 var = ffebld_trail (var))
01098 {
01099 if (ffebld_head (var) == root)
01100 continue;
01101 sv = ffeequiv_symbol (ffebld_head (var));
01102 if (sv == NULL)
01103 continue;
01104 ffesymbol_set_equiv (sv, NULL);
01105
01106 if (!ok
01107 || !ffeequiv_offset_ (&var_offset, sv,
01108 ffebld_head (var), TRUE,
01109 root_offset, TRUE))
01110 continue;
01111
01112 if (ffesymbol_rank (sv) == 0)
01113 num_elements = 1;
01114 else
01115 num_elements = ffebld_constant_integerdefault
01116 (ffebld_conter (ffesymbol_arraysize (sv)));
01117 ffetarget_layout (ffesymbol_text (sv), &alignment,
01118 &modulo, &size,
01119 ffesymbol_basictype (sv),
01120 ffesymbol_kindtype (sv),
01121 ffesymbol_size (sv), num_elements);
01122 pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
01123 ffestorag_ptr_to_modulo (st),
01124 var_offset, alignment, modulo);
01125 if (pad != 0)
01126 {
01127 ffebad_start (FFEBAD_EQUIV_ALIGN);
01128 ffebad_string (ffesymbol_text (sv));
01129 ffebad_finish ();
01130 continue;
01131 }
01132
01133 if ((vst = ffesymbol_storage (sv)) == NULL)
01134 {
01135
01136 new_storage = TRUE;
01137 vst = ffestorag_new (ffestorag_list_equivs (st));
01138 ffestorag_set_parent (vst, st);
01139
01140 ffestorag_set_init (vst, NULL);
01141 ffestorag_set_accretion (vst, NULL);
01142 ffestorag_set_symbol (vst, sv);
01143 ffestorag_set_size (vst, size);
01144 ffestorag_set_offset (vst, var_offset);
01145 ffestorag_set_alignment (vst, alignment);
01146 ffestorag_set_modulo (vst, modulo);
01147 ffestorag_set_type (vst, FFESTORAG_typeEQUIV);
01148 ffestorag_set_basictype (vst, ffesymbol_basictype (sv));
01149 ffestorag_set_kindtype (vst, ffesymbol_kindtype (sv));
01150 ffestorag_set_typesymbol (vst, sv);
01151 ffestorag_set_is_save (vst, FALSE);
01152 if (ffestorag_is_save (st))
01153 ffestorag_update_save (vst);
01154 ffestorag_set_is_init (vst, FALSE);
01155 if (ffestorag_is_init (st))
01156 ffestorag_update_init (vst);
01157 if (!ffetarget_offset_add (&size, var_offset, size))
01158
01159
01160 ffetarget_offset_overflow (ffesymbol_text (s));
01161 else if (size > ffestorag_size (st))
01162
01163 ffestorag_set_size (st, size);
01164 ffesymbol_set_storage (sv, vst);
01165 ffesymbol_set_common (sv, s);
01166 ffesymbol_signal_unreported (sv);
01167 ffestorag_update (st, sv, ffesymbol_basictype (sv),
01168 ffesymbol_kindtype (sv));
01169 if (ffesymbol_is_init (sv))
01170 init = TRUE;
01171 }
01172 else
01173 {
01174
01175 if (var_offset != ffestorag_offset (vst))
01176 {
01177 char io1[40];
01178 char io2[40];
01179
01180 sprintf (&io1[0], "%" ffetargetOffset_f "d", var_offset);
01181 sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (vst));
01182 ffebad_start (FFEBAD_EQUIV_MISMATCH);
01183 ffebad_string (ffesymbol_text (sv));
01184 ffebad_string (ffesymbol_text (s));
01185 ffebad_string (io1);
01186 ffebad_string (io2);
01187 ffebad_finish ();
01188 }
01189 }
01190 }
01191 }
01192
01193 }
01194 while (new_storage && need_storage);
01195
01196 ffeequiv_kill (seq);
01197 }
01198
01199 return init;
01200 }
01201
01202
01203
01204
01205
01206
01207
01208
01209
01210
01211
01212
01213
01214
01215
01216
01217 ffeequiv
01218 ffeequiv_merge (ffeequiv eq1, ffeequiv eq2, ffelexToken t)
01219 {
01220 ffebld list;
01221 ffebld eqs;
01222 ffesymbol symbol;
01223 ffebld last = NULL;
01224
01225
01226
01227
01228
01229
01230 if ((ffeequiv_common (eq1) != NULL) && (ffeequiv_common (eq2) != NULL)
01231 && (ffeequiv_common (eq1) != ffeequiv_common (eq2)))
01232 {
01233 ffebad_start (FFEBAD_EQUIV_COMMON);
01234 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
01235 ffebad_string (ffesymbol_text (ffeequiv_common (eq1)));
01236 ffebad_string (ffesymbol_text (ffeequiv_common (eq2)));
01237 ffebad_finish ();
01238 return NULL;
01239 }
01240
01241
01242
01243 if (ffeequiv_common (eq1) == NULL)
01244 ffeequiv_set_common (eq1, ffeequiv_common (eq2));
01245
01246
01247
01248 if (eq2->is_init)
01249 eq1->is_init = TRUE;
01250
01251 #if FFEGLOBAL_ENABLED
01252 if (eq1->is_init && (ffeequiv_common (eq1) != NULL))
01253 ffeglobal_init_common (ffeequiv_common (eq1), t);
01254 #endif
01255
01256
01257
01258
01259 if (ffeequiv_is_save (eq2))
01260 ffeequiv_update_save (eq1);
01261
01262
01263
01264
01265 if (ffeequiv_is_init (eq2))
01266 ffeequiv_update_init (eq1);
01267
01268
01269
01270
01271
01272 for (list = ffeequiv_list (eq2); list != NULL; list = ffebld_trail (list))
01273 {
01274 for (eqs = ffebld_head (list); eqs != NULL; eqs = ffebld_trail (eqs))
01275 {
01276 symbol = ffeequiv_symbol (ffebld_head (eqs));
01277 if (ffesymbol_equiv (symbol) == eq2)
01278 ffesymbol_set_equiv (symbol, eq1);
01279 else
01280 assert (ffesymbol_equiv (symbol) == eq1);
01281 }
01282
01283
01284
01285 if (ffebld_trail (list) == NULL)
01286 {
01287 last = list;
01288 break;
01289 }
01290 }
01291
01292
01293
01294
01295
01296 ffebld_set_trail (last, ffeequiv_list (eq1));
01297 ffeequiv_set_list (eq1, ffeequiv_list (eq2));
01298
01299
01300
01301 ffeequiv_kill (eq2);
01302
01303 return eq1;
01304 }
01305
01306
01307
01308
01309
01310
01311
01312
01313
01314 ffeequiv
01315 ffeequiv_new ()
01316 {
01317 ffeequiv eq;
01318
01319 eq = malloc_new_ks (ffe_pool_program_unit (), "ffeequiv", sizeof (*eq));
01320 eq->next = (ffeequiv) &ffeequiv_list_.first;
01321 eq->previous = ffeequiv_list_.last;
01322 ffeequiv_set_common (eq, NULL);
01323 ffeequiv_set_list (eq, NULL);
01324 ffeequiv_set_is_save (eq, FALSE);
01325 ffeequiv_set_is_init (eq, FALSE);
01326 eq->next->previous = eq;
01327 eq->previous->next = eq;
01328
01329 return eq;
01330 }
01331
01332
01333
01334
01335
01336
01337
01338
01339
01340
01341 ffesymbol
01342 ffeequiv_symbol (ffebld expr)
01343 {
01344 assert (expr != NULL);
01345
01346 again:
01347
01348 switch (ffebld_op (expr))
01349 {
01350 case FFEBLD_opARRAYREF:
01351 case FFEBLD_opSUBSTR:
01352 expr = ffebld_left (expr);
01353 goto again;
01354
01355 case FFEBLD_opSYMTER:
01356 return ffebld_symter (expr);
01357
01358 case FFEBLD_opANY:
01359 return NULL;
01360
01361 default:
01362 assert ("bad eq expr" == NULL);
01363 return NULL;
01364 }
01365 }
01366
01367
01368
01369
01370
01371
01372
01373
01374
01375
01376 void
01377 ffeequiv_update_init (ffeequiv eq)
01378 {
01379 ffebld list;
01380 ffebld item;
01381 ffebld expr;
01382
01383 if (eq->is_init)
01384 return;
01385
01386 eq->is_init = TRUE;
01387
01388 if ((eq->common != NULL)
01389 && !ffesymbol_is_init (eq->common))
01390 ffesymbol_update_init (eq->common);
01391
01392 for (list = eq->list; list != NULL; list = ffebld_trail (list))
01393 {
01394 for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
01395 {
01396 expr = ffebld_head (item);
01397
01398 again:
01399
01400 switch (ffebld_op (expr))
01401 {
01402 case FFEBLD_opANY:
01403 break;
01404
01405 case FFEBLD_opSYMTER:
01406 if (!ffesymbol_is_init (ffebld_symter (expr)))
01407 ffesymbol_update_init (ffebld_symter (expr));
01408 break;
01409
01410 case FFEBLD_opARRAYREF:
01411 expr = ffebld_left (expr);
01412 goto again;
01413
01414 case FFEBLD_opSUBSTR:
01415 expr = ffebld_left (expr);
01416 goto again;
01417
01418 default:
01419 assert ("bad op for ffeequiv_update_init" == NULL);
01420 break;
01421 }
01422 }
01423 }
01424 }
01425
01426
01427
01428
01429
01430
01431
01432
01433
01434
01435 void
01436 ffeequiv_update_save (ffeequiv eq)
01437 {
01438 ffebld list;
01439 ffebld item;
01440 ffebld expr;
01441
01442 if (eq->is_save)
01443 return;
01444
01445 eq->is_save = TRUE;
01446
01447 if ((eq->common != NULL)
01448 && !ffesymbol_is_save (eq->common))
01449 ffesymbol_update_save (eq->common);
01450
01451 for (list = eq->list; list != NULL; list = ffebld_trail (list))
01452 {
01453 for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
01454 {
01455 expr = ffebld_head (item);
01456
01457 again:
01458
01459 switch (ffebld_op (expr))
01460 {
01461 case FFEBLD_opANY:
01462 break;
01463
01464 case FFEBLD_opSYMTER:
01465 if (!ffesymbol_is_save (ffebld_symter (expr)))
01466 ffesymbol_update_save (ffebld_symter (expr));
01467 break;
01468
01469 case FFEBLD_opARRAYREF:
01470 expr = ffebld_left (expr);
01471 goto again;
01472
01473 case FFEBLD_opSUBSTR:
01474 expr = ffebld_left (expr);
01475 goto again;
01476
01477 default:
01478 assert ("bad op for ffeequiv_update_save" == NULL);
01479 break;
01480 }
01481 }
01482 }
01483 }