1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- B I N D E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Binderr; use Binderr; 27with Butil; use Butil; 28with Debug; use Debug; 29with Fname; use Fname; 30with Namet; use Namet; 31with Opt; use Opt; 32with Osint; 33with Output; use Output; 34with Targparm; use Targparm; 35 36with System.Case_Util; use System.Case_Util; 37 38package body Binde is 39 40 -- The following data structures are used to represent the graph that is 41 -- used to determine the elaboration order (using a topological sort). 42 43 -- The following structures are used to record successors. If A is a 44 -- successor of B in this table, it means that A must be elaborated 45 -- before B is elaborated. 46 47 type Successor_Id is new Nat; 48 -- Identification of single successor entry 49 50 No_Successor : constant Successor_Id := 0; 51 -- Used to indicate end of list of successors 52 53 type Elab_All_Id is new Nat; 54 -- Identification of Elab_All entry link 55 56 No_Elab_All_Link : constant Elab_All_Id := 0; 57 -- Used to indicate end of list 58 59 -- Succ_Reason indicates the reason for a particular elaboration link 60 61 type Succ_Reason is 62 (Withed, 63 -- After directly with's Before, so the spec of Before must be 64 -- elaborated before After is elaborated. 65 66 Elab, 67 -- After directly mentions Before in a pragma Elaborate, so the 68 -- body of Before must be elaborate before After is elaborated. 69 70 Elab_All, 71 -- After either mentions Before directly in a pragma Elaborate_All, 72 -- or mentions a third unit, X, which itself requires that Before be 73 -- elaborated before unit X is elaborated. The Elab_All_Link list 74 -- traces the dependencies in the latter case. 75 76 Elab_All_Desirable, 77 -- This is just like Elab_All, except that the elaborate all was not 78 -- explicitly present in the source, but rather was created by the 79 -- front end, which decided that it was "desirable". 80 81 Elab_Desirable, 82 -- This is just like Elab, except that the elaborate was not 83 -- explicitly present in the source, but rather was created by the 84 -- front end, which decided that it was "desirable". 85 86 Spec_First); 87 -- After is a body, and Before is the corresponding spec 88 89 -- Successor_Link contains the information for one link 90 91 type Successor_Link is record 92 Before : Unit_Id; 93 -- Predecessor unit 94 95 After : Unit_Id; 96 -- Successor unit 97 98 Next : Successor_Id; 99 -- Next successor on this list 100 101 Reason : Succ_Reason; 102 -- Reason for this link 103 104 Elab_Body : Boolean; 105 -- Set True if this link is needed for the special Elaborate_Body 106 -- processing described below. 107 108 Reason_Unit : Unit_Id; 109 -- For Reason = Elab, or Elab_All or Elab_Desirable, records the unit 110 -- containing the pragma leading to the link. 111 112 Elab_All_Link : Elab_All_Id; 113 -- If Reason = Elab_All or Elab_Desirable, then this points to the 114 -- first elment in a list of Elab_All entries that record the with 115 -- chain leading resulting in this particular dependency. 116 117 end record; 118 119 -- Note on handling of Elaborate_Body. Basically, if we have a pragma 120 -- Elaborate_Body in a unit, it means that the spec and body have to 121 -- be handled as a single entity from the point of view of determining 122 -- an elaboration order. What we do is to essentially remove the body 123 -- from consideration completely, and transfer all its links (other 124 -- than the spec link) to the spec. Then when then the spec gets chosen, 125 -- we choose the body right afterwards. We mark the links that get moved 126 -- from the body to the spec by setting their Elab_Body flag True, so 127 -- that we can understand what is going on. 128 129 Succ_First : constant := 1; 130 131 package Succ is new Table.Table ( 132 Table_Component_Type => Successor_Link, 133 Table_Index_Type => Successor_Id, 134 Table_Low_Bound => Succ_First, 135 Table_Initial => 500, 136 Table_Increment => 200, 137 Table_Name => "Succ"); 138 139 -- For the case of Elaborate_All, the following table is used to record 140 -- chains of with relationships that lead to the Elab_All link. These 141 -- are used solely for diagnostic purposes 142 143 type Elab_All_Entry is record 144 Needed_By : Unit_Name_Type; 145 -- Name of unit from which referencing unit was with'ed or otherwise 146 -- needed as a result of Elaborate_All or Elaborate_Desirable. 147 148 Next_Elab : Elab_All_Id; 149 -- Link to next entry on chain (No_Elab_All_Link marks end of list) 150 end record; 151 152 package Elab_All_Entries is new Table.Table ( 153 Table_Component_Type => Elab_All_Entry, 154 Table_Index_Type => Elab_All_Id, 155 Table_Low_Bound => 1, 156 Table_Initial => 2000, 157 Table_Increment => 200, 158 Table_Name => "Elab_All_Entries"); 159 160 -- A Unit_Node record is built for each active unit 161 162 type Unit_Node_Record is record 163 164 Successors : Successor_Id; 165 -- Pointer to list of links for successor nodes 166 167 Num_Pred : Int; 168 -- Number of predecessors for this unit. Normally non-negative, but 169 -- can go negative in the case of units chosen by the diagnose error 170 -- procedure (when cycles are being removed from the graph). 171 172 Nextnp : Unit_Id; 173 -- Forward pointer for list of units with no predecessors 174 175 Elab_Order : Nat; 176 -- Position in elaboration order (zero = not placed yet) 177 178 Visited : Boolean; 179 -- Used in computing transitive closure for elaborate all and 180 -- also in locating cycles and paths in the diagnose routines. 181 182 Elab_Position : Natural; 183 -- Initialized to zero. Set non-zero when a unit is chosen and 184 -- placed in the elaboration order. The value represents the 185 -- ordinal position in the elaboration order. 186 187 end record; 188 189 package UNR is new Table.Table ( 190 Table_Component_Type => Unit_Node_Record, 191 Table_Index_Type => Unit_Id, 192 Table_Low_Bound => First_Unit_Entry, 193 Table_Initial => 500, 194 Table_Increment => 200, 195 Table_Name => "UNR"); 196 197 No_Pred : Unit_Id; 198 -- Head of list of items with no predecessors 199 200 Num_Left : Int; 201 -- Number of entries not yet dealt with 202 203 Cur_Unit : Unit_Id; 204 -- Current unit, set by Gather_Dependencies, and picked up in Build_Link 205 -- to set the Reason_Unit field of the created dependency link. 206 207 Num_Chosen : Natural := 0; 208 -- Number of units chosen in the elaboration order so far 209 210 ----------------------- 211 -- Local Subprograms -- 212 ----------------------- 213 214 function Better_Choice (U1, U2 : Unit_Id) return Boolean; 215 -- U1 and U2 are both permitted candidates for selection as the next unit 216 -- to be elaborated. This function determines whether U1 is a better choice 217 -- than U2, i.e. should be elaborated in preference to U2, based on a set 218 -- of heuristics that establish a friendly and predictable order (see body 219 -- for details). The result is True if U1 is a better choice than U2, and 220 -- False if it is a worse choice, or there is no preference between them. 221 222 procedure Build_Link 223 (Before : Unit_Id; 224 After : Unit_Id; 225 R : Succ_Reason; 226 Ea_Id : Elab_All_Id := No_Elab_All_Link); 227 -- Establish a successor link, Before must be elaborated before After, and 228 -- the reason for the link is R. Ea_Id is the contents to be placed in the 229 -- Elab_All_Link of the entry. 230 231 procedure Choose (Chosen : Unit_Id); 232 -- Chosen is the next entry chosen in the elaboration order. This procedure 233 -- updates all data structures appropriately. 234 235 function Corresponding_Body (U : Unit_Id) return Unit_Id; 236 pragma Inline (Corresponding_Body); 237 -- Given a unit which is a spec for which there is a separate body, return 238 -- the unit id of the body. It is an error to call this routine with a unit 239 -- that is not a spec, or which does not have a separate body. 240 241 function Corresponding_Spec (U : Unit_Id) return Unit_Id; 242 pragma Inline (Corresponding_Spec); 243 -- Given a unit which is a body for which there is a separate spec, return 244 -- the unit id of the spec. It is an error to call this routine with a unit 245 -- that is not a body, or which does not have a separate spec. 246 247 procedure Diagnose_Elaboration_Problem; 248 -- Called when no elaboration order can be found. Outputs an appropriate 249 -- diagnosis of the problem, and then abandons the bind. 250 251 procedure Elab_All_Links 252 (Before : Unit_Id; 253 After : Unit_Id; 254 Reason : Succ_Reason; 255 Link : Elab_All_Id); 256 -- Used to compute the transitive closure of elaboration links for an 257 -- Elaborate_All pragma (Reason = Elab_All) or for an indication of 258 -- Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has 259 -- a pragma Elaborate_All or the front end has determined that a reference 260 -- probably requires Elaborate_All is required, and unit Before must be 261 -- previously elaborated. First a link is built making sure that unit 262 -- Before is elaborated before After, then a recursive call ensures that 263 -- we also build links for any units needed by Before (i.e. these units 264 -- must/should also be elaborated before After). Link is used to build 265 -- a chain of Elab_All_Entries to explain the reason for a link. The 266 -- value passed is the chain so far. 267 268 procedure Elab_Error_Msg (S : Successor_Id); 269 -- Given a successor link, outputs an error message of the form 270 -- "$ must be elaborated before $ ..." where ... is the reason. 271 272 procedure Gather_Dependencies; 273 -- Compute dependencies, building the Succ and UNR tables 274 275 function Is_Body_Unit (U : Unit_Id) return Boolean; 276 pragma Inline (Is_Body_Unit); 277 -- Determines if given unit is a body 278 279 function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean; 280 -- Returns True if corresponding unit is Pure or Preelaborate. Includes 281 -- dealing with testing flags on spec if it is given a body. 282 283 function Is_Waiting_Body (U : Unit_Id) return Boolean; 284 pragma Inline (Is_Waiting_Body); 285 -- Determines if U is a waiting body, defined as a body which has 286 -- not been elaborated, but whose spec has been elaborated. 287 288 function Make_Elab_Entry 289 (Unam : Unit_Name_Type; 290 Link : Elab_All_Id) return Elab_All_Id; 291 -- Make an Elab_All_Entries table entry with the given Unam and Link 292 293 function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean; 294 -- This is like Better_Choice, and has the same interface, but returns 295 -- true if U1 is a worse choice than U2 in the sense of the -p (pessimistic 296 -- elaboration order) switch. We still have to obey Ada rules, so it is 297 -- not quite the direct inverse of Better_Choice. 298 299 function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id; 300 -- This function uses the Info field set in the names table to obtain 301 -- the unit Id of a unit, given its name id value. 302 303 procedure Write_Dependencies; 304 -- Write out dependencies (called only if appropriate option is set) 305 306 procedure Write_Elab_All_Chain (S : Successor_Id); 307 -- If the reason for the link S is Elaborate_All or Elaborate_Desirable, 308 -- then this routine will output the "needed by" explanation chain. 309 310 ------------------- 311 -- Better_Choice -- 312 ------------------- 313 314 function Better_Choice (U1, U2 : Unit_Id) return Boolean is 315 UT1 : Unit_Record renames Units.Table (U1); 316 UT2 : Unit_Record renames Units.Table (U2); 317 318 begin 319 if Debug_Flag_B then 320 Write_Str ("Better_Choice ("); 321 Write_Unit_Name (UT1.Uname); 322 Write_Str (", "); 323 Write_Unit_Name (UT2.Uname); 324 Write_Line (")"); 325 end if; 326 327 -- Note: the checks here are applied in sequence, and the ordering is 328 -- significant (i.e. the more important criteria are applied first). 329 330 -- Prefer a waiting body to one that is not a waiting body 331 332 if Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then 333 if Debug_Flag_B then 334 Write_Line (" True: u1 is waiting body, u2 is not"); 335 end if; 336 337 return True; 338 339 elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then 340 if Debug_Flag_B then 341 Write_Line (" False: u2 is waiting body, u1 is not"); 342 end if; 343 344 return False; 345 346 -- Prefer a predefined unit to a non-predefined unit 347 348 elsif UT1.Predefined and then not UT2.Predefined then 349 if Debug_Flag_B then 350 Write_Line (" True: u1 is predefined, u2 is not"); 351 end if; 352 353 return True; 354 355 elsif UT2.Predefined and then not UT1.Predefined then 356 if Debug_Flag_B then 357 Write_Line (" False: u2 is predefined, u1 is not"); 358 end if; 359 360 return False; 361 362 -- Prefer an internal unit to a non-internal unit 363 364 elsif UT1.Internal and then not UT2.Internal then 365 if Debug_Flag_B then 366 Write_Line (" True: u1 is internal, u2 is not"); 367 end if; 368 return True; 369 370 elsif UT2.Internal and then not UT1.Internal then 371 if Debug_Flag_B then 372 Write_Line (" False: u2 is internal, u1 is not"); 373 end if; 374 375 return False; 376 377 -- Prefer a pure or preelaborable unit to one that is not 378 379 elsif Is_Pure_Or_Preelab_Unit (U1) 380 and then not 381 Is_Pure_Or_Preelab_Unit (U2) 382 then 383 if Debug_Flag_B then 384 Write_Line (" True: u1 is pure/preelab, u2 is not"); 385 end if; 386 387 return True; 388 389 elsif Is_Pure_Or_Preelab_Unit (U2) 390 and then not 391 Is_Pure_Or_Preelab_Unit (U1) 392 then 393 if Debug_Flag_B then 394 Write_Line (" False: u2 is pure/preelab, u1 is not"); 395 end if; 396 397 return False; 398 399 -- Prefer a body to a spec 400 401 elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then 402 if Debug_Flag_B then 403 Write_Line (" True: u1 is body, u2 is not"); 404 end if; 405 406 return True; 407 408 elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then 409 if Debug_Flag_B then 410 Write_Line (" False: u2 is body, u1 is not"); 411 end if; 412 413 return False; 414 415 -- If both are waiting bodies, then prefer the one whose spec is 416 -- more recently elaborated. Consider the following: 417 418 -- spec of A 419 -- spec of B 420 -- body of A or B? 421 422 -- The normal waiting body preference would have placed the body of 423 -- A before the spec of B if it could. Since it could not, there it 424 -- must be the case that A depends on B. It is therefore a good idea 425 -- to put the body of B first. 426 427 elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then 428 declare 429 Result : constant Boolean := 430 UNR.Table (Corresponding_Spec (U1)).Elab_Position > 431 UNR.Table (Corresponding_Spec (U2)).Elab_Position; 432 begin 433 if Debug_Flag_B then 434 if Result then 435 Write_Line (" True: based on waiting body elab positions"); 436 else 437 Write_Line (" False: based on waiting body elab positions"); 438 end if; 439 end if; 440 441 return Result; 442 end; 443 end if; 444 445 -- Remaining choice rules are disabled by Debug flag -do 446 447 if not Debug_Flag_O then 448 449 -- The following deal with the case of specs which have been marked 450 -- as Elaborate_Body_Desirable. We generally want to delay these 451 -- specs as long as possible, so that the bodies have a better chance 452 -- of being elaborated closer to the specs. 453 454 -- If we have two units, one of which is a spec for which this flag 455 -- is set, and the other is not, we prefer to delay the spec for 456 -- which the flag is set. 457 458 if not UT1.Elaborate_Body_Desirable 459 and then UT2.Elaborate_Body_Desirable 460 then 461 if Debug_Flag_B then 462 Write_Line (" True: u1 is elab body desirable, u2 is not"); 463 end if; 464 465 return True; 466 467 elsif not UT2.Elaborate_Body_Desirable 468 and then UT1.Elaborate_Body_Desirable 469 then 470 if Debug_Flag_B then 471 Write_Line (" False: u1 is elab body desirable, u2 is not"); 472 end if; 473 474 return False; 475 476 -- If we have two specs that are both marked as Elaborate_Body 477 -- desirable, we prefer the one whose body is nearer to being able 478 -- to be elaborated, based on the Num_Pred count. This helps to 479 -- ensure bodies are as close to specs as possible. 480 481 elsif UT1.Elaborate_Body_Desirable 482 and then UT2.Elaborate_Body_Desirable 483 then 484 declare 485 Result : constant Boolean := 486 UNR.Table (Corresponding_Body (U1)).Num_Pred < 487 UNR.Table (Corresponding_Body (U2)).Num_Pred; 488 begin 489 if Debug_Flag_B then 490 if Result then 491 Write_Line (" True based on Num_Pred compare"); 492 else 493 Write_Line (" False based on Num_Pred compare"); 494 end if; 495 end if; 496 497 return Result; 498 end; 499 end if; 500 end if; 501 502 -- If we fall through, it means that no preference rule applies, so we 503 -- use alphabetical order to at least give a deterministic result. 504 505 if Debug_Flag_B then 506 Write_Line (" choose on alpha order"); 507 end if; 508 509 return Uname_Less (UT1.Uname, UT2.Uname); 510 end Better_Choice; 511 512 ---------------- 513 -- Build_Link -- 514 ---------------- 515 516 procedure Build_Link 517 (Before : Unit_Id; 518 After : Unit_Id; 519 R : Succ_Reason; 520 Ea_Id : Elab_All_Id := No_Elab_All_Link) 521 is 522 Cspec : Unit_Id; 523 524 begin 525 Succ.Increment_Last; 526 Succ.Table (Succ.Last).Before := Before; 527 Succ.Table (Succ.Last).Next := UNR.Table (Before).Successors; 528 UNR.Table (Before).Successors := Succ.Last; 529 Succ.Table (Succ.Last).Reason := R; 530 Succ.Table (Succ.Last).Reason_Unit := Cur_Unit; 531 Succ.Table (Succ.Last).Elab_All_Link := Ea_Id; 532 533 -- Deal with special Elab_Body case. If the After of this link is 534 -- a body whose spec has Elaborate_All set, and this is not the link 535 -- directly from the body to the spec, then we make the After of the 536 -- link reference its spec instead, marking the link appropriately. 537 538 if Units.Table (After).Utype = Is_Body then 539 Cspec := Corresponding_Spec (After); 540 541 if Units.Table (Cspec).Elaborate_Body 542 and then Cspec /= Before 543 then 544 Succ.Table (Succ.Last).After := Cspec; 545 Succ.Table (Succ.Last).Elab_Body := True; 546 UNR.Table (Cspec).Num_Pred := UNR.Table (Cspec).Num_Pred + 1; 547 return; 548 end if; 549 end if; 550 551 -- Fall through on normal case 552 553 Succ.Table (Succ.Last).After := After; 554 Succ.Table (Succ.Last).Elab_Body := False; 555 UNR.Table (After).Num_Pred := UNR.Table (After).Num_Pred + 1; 556 end Build_Link; 557 558 ------------ 559 -- Choose -- 560 ------------ 561 562 procedure Choose (Chosen : Unit_Id) is 563 S : Successor_Id; 564 U : Unit_Id; 565 566 begin 567 if Debug_Flag_C then 568 Write_Str ("Choosing Unit "); 569 Write_Unit_Name (Units.Table (Chosen).Uname); 570 Write_Eol; 571 end if; 572 573 -- Add to elaboration order. Note that units having no elaboration 574 -- code are not treated specially yet. The special casing of this 575 -- is in Bindgen, where Gen_Elab_Calls skips over them. Meanwhile 576 -- we need them here, because the object file list is also driven 577 -- by the contents of the Elab_Order table. 578 579 Elab_Order.Increment_Last; 580 Elab_Order.Table (Elab_Order.Last) := Chosen; 581 582 -- Remove from No_Pred list. This is a little inefficient and may 583 -- be we should doubly link the list, but it will do for now. 584 585 if No_Pred = Chosen then 586 No_Pred := UNR.Table (Chosen).Nextnp; 587 588 else 589 -- Note that we just ignore the situation where it does not 590 -- appear in the No_Pred list, this happens in calls from the 591 -- Diagnose_Elaboration_Problem routine, where cycles are being 592 -- removed arbitrarily from the graph. 593 594 U := No_Pred; 595 while U /= No_Unit_Id loop 596 if UNR.Table (U).Nextnp = Chosen then 597 UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp; 598 exit; 599 end if; 600 601 U := UNR.Table (U).Nextnp; 602 end loop; 603 end if; 604 605 -- For all successors, decrement the number of predecessors, and 606 -- if it becomes zero, then add to no predecessor list. 607 608 S := UNR.Table (Chosen).Successors; 609 while S /= No_Successor loop 610 U := Succ.Table (S).After; 611 UNR.Table (U).Num_Pred := UNR.Table (U).Num_Pred - 1; 612 613 if Debug_Flag_N then 614 Write_Str (" decrementing Num_Pred for unit "); 615 Write_Unit_Name (Units.Table (U).Uname); 616 Write_Str (" new value = "); 617 Write_Int (UNR.Table (U).Num_Pred); 618 Write_Eol; 619 end if; 620 621 if UNR.Table (U).Num_Pred = 0 then 622 UNR.Table (U).Nextnp := No_Pred; 623 No_Pred := U; 624 end if; 625 626 S := Succ.Table (S).Next; 627 end loop; 628 629 -- All done, adjust number of units left count and set elaboration pos 630 631 Num_Left := Num_Left - 1; 632 Num_Chosen := Num_Chosen + 1; 633 UNR.Table (Chosen).Elab_Position := Num_Chosen; 634 Units.Table (Chosen).Elab_Position := Num_Chosen; 635 636 -- If we just chose a spec with Elaborate_Body set, then we 637 -- must immediately elaborate the body, before any other units. 638 639 if Units.Table (Chosen).Elaborate_Body then 640 641 -- If the unit is a spec only, then there is no body. This is a bit 642 -- odd given that Elaborate_Body is here, but it is valid in an 643 -- RCI unit, where we only have the interface in the stub bind. 644 645 if Units.Table (Chosen).Utype = Is_Spec_Only 646 and then Units.Table (Chosen).RCI 647 then 648 null; 649 else 650 Choose (Corresponding_Body (Chosen)); 651 end if; 652 end if; 653 end Choose; 654 655 ------------------------ 656 -- Corresponding_Body -- 657 ------------------------ 658 659 -- Currently if the body and spec are separate, then they appear as 660 -- two separate units in the same ALI file, with the body appearing 661 -- first and the spec appearing second. 662 663 function Corresponding_Body (U : Unit_Id) return Unit_Id is 664 begin 665 pragma Assert (Units.Table (U).Utype = Is_Spec); 666 return U - 1; 667 end Corresponding_Body; 668 669 ------------------------ 670 -- Corresponding_Spec -- 671 ------------------------ 672 673 -- Currently if the body and spec are separate, then they appear as 674 -- two separate units in the same ALI file, with the body appearing 675 -- first and the spec appearing second. 676 677 function Corresponding_Spec (U : Unit_Id) return Unit_Id is 678 begin 679 pragma Assert (Units.Table (U).Utype = Is_Body); 680 return U + 1; 681 end Corresponding_Spec; 682 683 ---------------------------------- 684 -- Diagnose_Elaboration_Problem -- 685 ---------------------------------- 686 687 procedure Diagnose_Elaboration_Problem is 688 689 function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean; 690 -- Recursive routine used to find a path from node Ufrom to node Uto. 691 -- If a path exists, returns True and outputs an appropriate set of 692 -- error messages giving the path. Also calls Choose for each of the 693 -- nodes so that they get removed from the remaining set. There are 694 -- two cases of calls, either Ufrom = Uto for an attempt to find a 695 -- cycle, or Ufrom is a spec and Uto the corresponding body for the 696 -- case of an unsatisfiable Elaborate_Body pragma. ML is the minimum 697 -- acceptable length for a path. 698 699 --------------- 700 -- Find_Path -- 701 --------------- 702 703 function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean is 704 705 function Find_Link (U : Unit_Id; PL : Nat) return Boolean; 706 -- This is the inner recursive routine, it determines if a path 707 -- exists from U to Uto, and if so returns True and outputs the 708 -- appropriate set of error messages. PL is the path length 709 710 --------------- 711 -- Find_Link -- 712 --------------- 713 714 function Find_Link (U : Unit_Id; PL : Nat) return Boolean is 715 S : Successor_Id; 716 717 begin 718 -- Recursion ends if we are at terminating node and the path 719 -- is sufficiently long, generate error message and return True. 720 721 if U = Uto and then PL >= ML then 722 Choose (U); 723 return True; 724 725 -- All done if already visited, otherwise mark as visited 726 727 elsif UNR.Table (U).Visited then 728 return False; 729 730 -- Otherwise mark as visited and look at all successors 731 732 else 733 UNR.Table (U).Visited := True; 734 735 S := UNR.Table (U).Successors; 736 while S /= No_Successor loop 737 if Find_Link (Succ.Table (S).After, PL + 1) then 738 Elab_Error_Msg (S); 739 Choose (U); 740 return True; 741 end if; 742 743 S := Succ.Table (S).Next; 744 end loop; 745 746 -- Falling through means this does not lead to a path 747 748 return False; 749 end if; 750 end Find_Link; 751 752 -- Start of processing for Find_Path 753 754 begin 755 -- Initialize all non-chosen nodes to not visisted yet 756 757 for U in Units.First .. Units.Last loop 758 UNR.Table (U).Visited := UNR.Table (U).Elab_Position /= 0; 759 end loop; 760 761 -- Now try to find the path 762 763 return Find_Link (Ufrom, 0); 764 end Find_Path; 765 766 -- Start of processing for Diagnose_Elaboration_Error 767 768 begin 769 Set_Standard_Error; 770 771 -- Output state of things if debug flag N set 772 773 if Debug_Flag_N then 774 declare 775 NP : Int; 776 777 begin 778 Write_Eol; 779 Write_Eol; 780 Write_Str ("Diagnose_Elaboration_Problem called"); 781 Write_Eol; 782 Write_Str ("List of remaining unchosen units and predecessors"); 783 Write_Eol; 784 785 for U in Units.First .. Units.Last loop 786 if UNR.Table (U).Elab_Position = 0 then 787 NP := UNR.Table (U).Num_Pred; 788 Write_Eol; 789 Write_Str (" Unchosen unit: #"); 790 Write_Int (Int (U)); 791 Write_Str (" "); 792 Write_Unit_Name (Units.Table (U).Uname); 793 Write_Str (" (Num_Pred = "); 794 Write_Int (NP); 795 Write_Char (')'); 796 Write_Eol; 797 798 if NP = 0 then 799 if Units.Table (U).Elaborate_Body then 800 Write_Str 801 (" (not chosen because of Elaborate_Body)"); 802 Write_Eol; 803 else 804 Write_Str (" ****************** why not chosen?"); 805 Write_Eol; 806 end if; 807 end if; 808 809 -- Search links list to find unchosen predecessors 810 811 for S in Succ.First .. Succ.Last loop 812 declare 813 SL : Successor_Link renames Succ.Table (S); 814 815 begin 816 if SL.After = U 817 and then UNR.Table (SL.Before).Elab_Position = 0 818 then 819 Write_Str (" unchosen predecessor: #"); 820 Write_Int (Int (SL.Before)); 821 Write_Str (" "); 822 Write_Unit_Name (Units.Table (SL.Before).Uname); 823 Write_Eol; 824 NP := NP - 1; 825 end if; 826 end; 827 end loop; 828 829 if NP /= 0 then 830 Write_Str (" **************** Num_Pred value wrong!"); 831 Write_Eol; 832 end if; 833 end if; 834 end loop; 835 end; 836 end if; 837 838 -- Output the header for the error, and manually increment the 839 -- error count. We are using Error_Msg_Output rather than Error_Msg 840 -- here for two reasons: 841 842 -- This is really only one error, not one for each line 843 -- We want this output on standard output since it is voluminous 844 845 -- But we do need to deal with the error count manually in this case 846 847 Errors_Detected := Errors_Detected + 1; 848 Error_Msg_Output ("elaboration circularity detected", Info => False); 849 850 -- Try to find cycles starting with any of the remaining nodes that have 851 -- not yet been chosen. There must be at least one (there is some reason 852 -- we are being called). 853 854 for U in Units.First .. Units.Last loop 855 if UNR.Table (U).Elab_Position = 0 then 856 if Find_Path (U, U, 1) then 857 raise Unrecoverable_Error; 858 end if; 859 end if; 860 end loop; 861 862 -- We should never get here, since we were called for some reason, 863 -- and we should have found and eliminated at least one bad path. 864 865 raise Program_Error; 866 end Diagnose_Elaboration_Problem; 867 868 -------------------- 869 -- Elab_All_Links -- 870 -------------------- 871 872 procedure Elab_All_Links 873 (Before : Unit_Id; 874 After : Unit_Id; 875 Reason : Succ_Reason; 876 Link : Elab_All_Id) 877 is 878 begin 879 if UNR.Table (Before).Visited then 880 return; 881 end if; 882 883 -- Build the direct link for Before 884 885 UNR.Table (Before).Visited := True; 886 Build_Link (Before, After, Reason, Link); 887 888 -- Process all units with'ed by Before recursively 889 890 for W in 891 Units.Table (Before).First_With .. Units.Table (Before).Last_With 892 loop 893 -- Skip if this with is an interface to a stand-alone library. 894 -- Skip also if no ALI file for this WITH, happens for language 895 -- defined generics while bootstrapping the compiler (see body of 896 -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited 897 -- with clause, which does not impose an elaboration link. 898 899 if not Withs.Table (W).SAL_Interface 900 and then Withs.Table (W).Afile /= No_File 901 and then not Withs.Table (W).Limited_With 902 then 903 declare 904 Info : constant Int := 905 Get_Name_Table_Info (Withs.Table (W).Uname); 906 907 begin 908 -- If the unit is unknown, for some unknown reason, fail 909 -- graciously explaining that the unit is unknown. Without 910 -- this check, gnatbind will crash in Unit_Id_Of. 911 912 if Info = 0 or else Unit_Id (Info) = No_Unit_Id then 913 declare 914 Withed : String := 915 Get_Name_String (Withs.Table (W).Uname); 916 Last_Withed : Natural := Withed'Last; 917 Withing : String := 918 Get_Name_String (Units.Table (Before).Uname); 919 Last_Withing : Natural := Withing'Last; 920 Spec_Body : String := " (Spec)"; 921 922 begin 923 To_Mixed (Withed); 924 To_Mixed (Withing); 925 926 if Last_Withed > 2 and then 927 Withed (Last_Withed - 1) = '%' 928 then 929 Last_Withed := Last_Withed - 2; 930 end if; 931 932 if Last_Withing > 2 and then 933 Withing (Last_Withing - 1) = '%' 934 then 935 Last_Withing := Last_Withing - 2; 936 end if; 937 938 if Units.Table (Before).Utype = Is_Body or else 939 Units.Table (Before).Utype = Is_Body_Only 940 then 941 Spec_Body := " (Body)"; 942 end if; 943 944 Osint.Fail 945 ("could not find unit " 946 & Withed (Withed'First .. Last_Withed) & " needed by " 947 & Withing (Withing'First .. Last_Withing) & Spec_Body); 948 end; 949 end if; 950 951 Elab_All_Links 952 (Unit_Id_Of (Withs.Table (W).Uname), 953 After, 954 Reason, 955 Make_Elab_Entry (Withs.Table (W).Uname, Link)); 956 end; 957 end if; 958 end loop; 959 960 -- Process corresponding body, if there is one 961 962 if Units.Table (Before).Utype = Is_Spec then 963 Elab_All_Links 964 (Corresponding_Body (Before), 965 After, Reason, 966 Make_Elab_Entry 967 (Units.Table (Corresponding_Body (Before)).Uname, Link)); 968 end if; 969 end Elab_All_Links; 970 971 -------------------- 972 -- Elab_Error_Msg -- 973 -------------------- 974 975 procedure Elab_Error_Msg (S : Successor_Id) is 976 SL : Successor_Link renames Succ.Table (S); 977 978 begin 979 -- Nothing to do if internal unit involved and no -da flag 980 981 if not Debug_Flag_A 982 and then 983 (Is_Internal_File_Name (Units.Table (SL.Before).Sfile) 984 or else 985 Is_Internal_File_Name (Units.Table (SL.After).Sfile)) 986 then 987 return; 988 end if; 989 990 -- Here we want to generate output 991 992 Error_Msg_Unit_1 := Units.Table (SL.Before).Uname; 993 994 if SL.Elab_Body then 995 Error_Msg_Unit_2 := Units.Table (Corresponding_Body (SL.After)).Uname; 996 else 997 Error_Msg_Unit_2 := Units.Table (SL.After).Uname; 998 end if; 999 1000 Error_Msg_Output (" $ must be elaborated before $", Info => True); 1001 1002 Error_Msg_Unit_1 := Units.Table (SL.Reason_Unit).Uname; 1003 1004 case SL.Reason is 1005 when Withed => 1006 Error_Msg_Output 1007 (" reason: with clause", 1008 Info => True); 1009 1010 when Elab => 1011 Error_Msg_Output 1012 (" reason: pragma Elaborate in unit $", 1013 Info => True); 1014 1015 when Elab_All => 1016 Error_Msg_Output 1017 (" reason: pragma Elaborate_All in unit $", 1018 Info => True); 1019 1020 when Elab_All_Desirable => 1021 Error_Msg_Output 1022 (" reason: implicit Elaborate_All in unit $", 1023 Info => True); 1024 1025 Error_Msg_Output 1026 (" recompile $ with -gnatel for full details", 1027 Info => True); 1028 1029 when Elab_Desirable => 1030 Error_Msg_Output 1031 (" reason: implicit Elaborate in unit $", 1032 Info => True); 1033 1034 Error_Msg_Output 1035 (" recompile $ with -gnatel for full details", 1036 Info => True); 1037 1038 when Spec_First => 1039 Error_Msg_Output 1040 (" reason: spec always elaborated before body", 1041 Info => True); 1042 end case; 1043 1044 Write_Elab_All_Chain (S); 1045 1046 if SL.Elab_Body then 1047 Error_Msg_Unit_1 := Units.Table (SL.Before).Uname; 1048 Error_Msg_Unit_2 := Units.Table (SL.After).Uname; 1049 Error_Msg_Output 1050 (" $ must therefore be elaborated before $", 1051 True); 1052 1053 Error_Msg_Unit_1 := Units.Table (SL.After).Uname; 1054 Error_Msg_Output 1055 (" (because $ has a pragma Elaborate_Body)", 1056 True); 1057 end if; 1058 1059 if not Zero_Formatting then 1060 Write_Eol; 1061 end if; 1062 end Elab_Error_Msg; 1063 1064 --------------------- 1065 -- Find_Elab_Order -- 1066 --------------------- 1067 1068 procedure Find_Elab_Order is 1069 U : Unit_Id; 1070 Best_So_Far : Unit_Id; 1071 1072 begin 1073 Succ.Init; 1074 Num_Left := Int (Units.Last - Units.First + 1); 1075 1076 -- Initialize unit table for elaboration control 1077 1078 for U in Units.First .. Units.Last loop 1079 UNR.Increment_Last; 1080 UNR.Table (UNR.Last).Successors := No_Successor; 1081 UNR.Table (UNR.Last).Num_Pred := 0; 1082 UNR.Table (UNR.Last).Nextnp := No_Unit_Id; 1083 UNR.Table (UNR.Last).Elab_Order := 0; 1084 UNR.Table (UNR.Last).Elab_Position := 0; 1085 end loop; 1086 1087 -- Output warning if -p used with no -gnatE units 1088 1089 if Pessimistic_Elab_Order 1090 and not Dynamic_Elaboration_Checks_Specified 1091 then 1092 if OpenVMS_On_Target then 1093 Error_Msg ("?use of /PESSIMISTIC_ELABORATION questionable"); 1094 else 1095 Error_Msg ("?use of -p switch questionable"); 1096 end if; 1097 1098 Error_Msg ("?since all units compiled with static elaboration model"); 1099 end if; 1100 1101 -- Gather dependencies and output them if option set 1102 1103 Gather_Dependencies; 1104 1105 -- Output elaboration dependencies if option is set 1106 1107 if Elab_Dependency_Output or Debug_Flag_E then 1108 Write_Dependencies; 1109 end if; 1110 1111 -- Initialize the no predecessor list 1112 1113 No_Pred := No_Unit_Id; 1114 1115 for U in UNR.First .. UNR.Last loop 1116 if UNR.Table (U).Num_Pred = 0 then 1117 UNR.Table (U).Nextnp := No_Pred; 1118 No_Pred := U; 1119 end if; 1120 end loop; 1121 1122 -- OK, now we determine the elaboration order proper. All we do is to 1123 -- select the best choice from the no predecessor list until all the 1124 -- nodes have been chosen. 1125 1126 Outer : loop 1127 1128 -- If there are no nodes with predecessors, then either we are 1129 -- done, as indicated by Num_Left being set to zero, or we have 1130 -- a circularity. In the latter case, diagnose the circularity, 1131 -- removing it from the graph and continue 1132 1133 Get_No_Pred : while No_Pred = No_Unit_Id loop 1134 exit Outer when Num_Left < 1; 1135 Diagnose_Elaboration_Problem; 1136 end loop Get_No_Pred; 1137 1138 U := No_Pred; 1139 Best_So_Far := No_Unit_Id; 1140 1141 -- Loop to choose best entry in No_Pred list 1142 1143 No_Pred_Search : loop 1144 if Debug_Flag_N then 1145 Write_Str (" considering choice of "); 1146 Write_Unit_Name (Units.Table (U).Uname); 1147 Write_Eol; 1148 1149 if Units.Table (U).Elaborate_Body then 1150 Write_Str 1151 (" Elaborate_Body = True, Num_Pred for body = "); 1152 Write_Int 1153 (UNR.Table (Corresponding_Body (U)).Num_Pred); 1154 else 1155 Write_Str 1156 (" Elaborate_Body = False"); 1157 end if; 1158 1159 Write_Eol; 1160 end if; 1161 1162 -- This is a candididate to be considered for choice 1163 1164 if Best_So_Far = No_Unit_Id 1165 or else ((not Pessimistic_Elab_Order) 1166 and then Better_Choice (U, Best_So_Far)) 1167 or else (Pessimistic_Elab_Order 1168 and then Pessimistic_Better_Choice (U, Best_So_Far)) 1169 then 1170 if Debug_Flag_N then 1171 Write_Str (" tentatively chosen (best so far)"); 1172 Write_Eol; 1173 end if; 1174 1175 Best_So_Far := U; 1176 end if; 1177 1178 U := UNR.Table (U).Nextnp; 1179 exit No_Pred_Search when U = No_Unit_Id; 1180 end loop No_Pred_Search; 1181 1182 -- If no candididate chosen, it means that no unit has No_Pred = 0, 1183 -- but there are units left, hence we have a circular dependency, 1184 -- which we will get Diagnose_Elaboration_Problem to diagnose it. 1185 1186 if Best_So_Far = No_Unit_Id then 1187 Diagnose_Elaboration_Problem; 1188 1189 -- Otherwise choose the best candidate found 1190 1191 else 1192 Choose (Best_So_Far); 1193 end if; 1194 end loop Outer; 1195 end Find_Elab_Order; 1196 1197 ------------------------- 1198 -- Gather_Dependencies -- 1199 ------------------------- 1200 1201 procedure Gather_Dependencies is 1202 Withed_Unit : Unit_Id; 1203 1204 begin 1205 -- Loop through all units 1206 1207 for U in Units.First .. Units.Last loop 1208 Cur_Unit := U; 1209 1210 -- If this is not an interface to a stand-alone library and 1211 -- there is a body and a spec, then spec must be elaborated first 1212 -- Note that the corresponding spec immediately follows the body 1213 1214 if not Units.Table (U).SAL_Interface 1215 and then Units.Table (U).Utype = Is_Body 1216 then 1217 Build_Link (Corresponding_Spec (U), U, Spec_First); 1218 end if; 1219 1220 -- If this unit is not an interface to a stand-alone library, 1221 -- process WITH references for this unit ignoring generic units and 1222 -- interfaces to stand-alone libraries. 1223 1224 if not Units.Table (U).SAL_Interface then 1225 for 1226 W in Units.Table (U).First_With .. Units.Table (U).Last_With 1227 loop 1228 if Withs.Table (W).Sfile /= No_File 1229 and then (not Withs.Table (W).SAL_Interface) 1230 then 1231 -- Check for special case of withing a unit that does not 1232 -- exist any more. If the unit was completely missing we 1233 -- would already have detected this, but a nasty case arises 1234 -- when we have a subprogram body with no spec, and some 1235 -- obsolete unit with's a previous (now disappeared) spec. 1236 1237 if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then 1238 Error_Msg_File_1 := Units.Table (U).Sfile; 1239 Error_Msg_Unit_1 := Withs.Table (W).Uname; 1240 Error_Msg ("{ depends on $ which no longer exists"); 1241 goto Next_With; 1242 end if; 1243 1244 Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname); 1245 1246 -- Pragma Elaborate_All case, for this we use the recursive 1247 -- Elab_All_Links procedure to establish the links. 1248 1249 if Withs.Table (W).Elaborate_All then 1250 1251 -- Reset flags used to stop multiple visits to a given 1252 -- node. 1253 1254 for Uref in UNR.First .. UNR.Last loop 1255 UNR.Table (Uref).Visited := False; 1256 end loop; 1257 1258 -- Now establish all the links we need 1259 1260 Elab_All_Links 1261 (Withed_Unit, U, Elab_All, 1262 Make_Elab_Entry 1263 (Withs.Table (W).Uname, No_Elab_All_Link)); 1264 1265 -- Elaborate_All_Desirable case, for this we establish the 1266 -- same links as above, but with a different reason. 1267 1268 elsif Withs.Table (W).Elab_All_Desirable then 1269 1270 -- Reset flags used to stop multiple visits to a given 1271 -- node. 1272 1273 for Uref in UNR.First .. UNR.Last loop 1274 UNR.Table (Uref).Visited := False; 1275 end loop; 1276 1277 -- Now establish all the links we need 1278 1279 Elab_All_Links 1280 (Withed_Unit, U, Elab_All_Desirable, 1281 Make_Elab_Entry 1282 (Withs.Table (W).Uname, No_Elab_All_Link)); 1283 1284 -- Pragma Elaborate case. We must build a link for the 1285 -- withed unit itself, and also the corresponding body if 1286 -- there is one. 1287 1288 -- However, skip this processing if there is no ALI file for 1289 -- the WITH entry, because this means it is a generic (even 1290 -- when we fix the generics so that an ALI file is present, 1291 -- we probably still will have no ALI file for unchecked and 1292 -- other special cases). 1293 1294 elsif Withs.Table (W).Elaborate 1295 and then Withs.Table (W).Afile /= No_File 1296 then 1297 Build_Link (Withed_Unit, U, Withed); 1298 1299 if Units.Table (Withed_Unit).Utype = Is_Spec then 1300 Build_Link 1301 (Corresponding_Body (Withed_Unit), U, Elab); 1302 end if; 1303 1304 -- Elaborate_Desirable case, for this we establish 1305 -- the same links as above, but with a different reason. 1306 1307 elsif Withs.Table (W).Elab_Desirable then 1308 Build_Link (Withed_Unit, U, Withed); 1309 1310 if Units.Table (Withed_Unit).Utype = Is_Spec then 1311 Build_Link 1312 (Corresponding_Body (Withed_Unit), 1313 U, Elab_Desirable); 1314 end if; 1315 1316 -- A limited_with does not establish an elaboration 1317 -- dependence (that's the whole point).. 1318 1319 elsif Withs.Table (W).Limited_With then 1320 null; 1321 1322 -- Case of normal WITH with no elaboration pragmas, just 1323 -- build the single link to the directly referenced unit 1324 1325 else 1326 Build_Link (Withed_Unit, U, Withed); 1327 end if; 1328 end if; 1329 1330 <<Next_With>> 1331 null; 1332 end loop; 1333 end if; 1334 end loop; 1335 end Gather_Dependencies; 1336 1337 ------------------ 1338 -- Is_Body_Unit -- 1339 ------------------ 1340 1341 function Is_Body_Unit (U : Unit_Id) return Boolean is 1342 begin 1343 return Units.Table (U).Utype = Is_Body 1344 or else Units.Table (U).Utype = Is_Body_Only; 1345 end Is_Body_Unit; 1346 1347 ----------------------------- 1348 -- Is_Pure_Or_Preelab_Unit -- 1349 ----------------------------- 1350 1351 function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean is 1352 begin 1353 -- If we have a body with separate spec, test flags on the spec 1354 1355 if Units.Table (U).Utype = Is_Body then 1356 return Units.Table (U + 1).Preelab 1357 or else 1358 Units.Table (U + 1).Pure; 1359 1360 -- Otherwise we have a spec or body acting as spec, test flags on unit 1361 1362 else 1363 return Units.Table (U).Preelab 1364 or else 1365 Units.Table (U).Pure; 1366 end if; 1367 end Is_Pure_Or_Preelab_Unit; 1368 1369 --------------------- 1370 -- Is_Waiting_Body -- 1371 --------------------- 1372 1373 function Is_Waiting_Body (U : Unit_Id) return Boolean is 1374 begin 1375 return Units.Table (U).Utype = Is_Body 1376 and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0; 1377 end Is_Waiting_Body; 1378 1379 --------------------- 1380 -- Make_Elab_Entry -- 1381 --------------------- 1382 1383 function Make_Elab_Entry 1384 (Unam : Unit_Name_Type; 1385 Link : Elab_All_Id) return Elab_All_Id 1386 is 1387 begin 1388 Elab_All_Entries.Increment_Last; 1389 Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam; 1390 Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link; 1391 return Elab_All_Entries.Last; 1392 end Make_Elab_Entry; 1393 1394 ------------------------------- 1395 -- Pessimistic_Better_Choice -- 1396 ------------------------------- 1397 1398 function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean is 1399 UT1 : Unit_Record renames Units.Table (U1); 1400 UT2 : Unit_Record renames Units.Table (U2); 1401 1402 begin 1403 if Debug_Flag_B then 1404 Write_Str ("Pessimistic_Better_Choice ("); 1405 Write_Unit_Name (UT1.Uname); 1406 Write_Str (", "); 1407 Write_Unit_Name (UT2.Uname); 1408 Write_Line (")"); 1409 end if; 1410 1411 -- Note: the checks here are applied in sequence, and the ordering is 1412 -- significant (i.e. the more important criteria are applied first). 1413 1414 -- If either unit is predefined or internal, then we use the normal 1415 -- Better_Choice rule, since we don't want to disturb the elaboration 1416 -- rules of the language with -p, same treatment for Pure/Preelab. 1417 1418 -- Prefer a predefined unit to a non-predefined unit 1419 1420 if UT1.Predefined and then not UT2.Predefined then 1421 if Debug_Flag_B then 1422 Write_Line (" True: u1 is predefined, u2 is not"); 1423 end if; 1424 1425 return True; 1426 1427 elsif UT2.Predefined and then not UT1.Predefined then 1428 if Debug_Flag_B then 1429 Write_Line (" False: u2 is predefined, u1 is not"); 1430 end if; 1431 1432 return False; 1433 1434 -- Prefer an internal unit to a non-internal unit 1435 1436 elsif UT1.Internal and then not UT2.Internal then 1437 if Debug_Flag_B then 1438 Write_Line (" True: u1 is internal, u2 is not"); 1439 end if; 1440 1441 return True; 1442 1443 elsif UT2.Internal and then not UT1.Internal then 1444 if Debug_Flag_B then 1445 Write_Line (" False: u2 is internal, u1 is not"); 1446 end if; 1447 1448 return False; 1449 1450 -- Prefer a pure or preelaborable unit to one that is not 1451 1452 elsif Is_Pure_Or_Preelab_Unit (U1) 1453 and then not 1454 Is_Pure_Or_Preelab_Unit (U2) 1455 then 1456 if Debug_Flag_B then 1457 Write_Line (" True: u1 is pure/preelab, u2 is not"); 1458 end if; 1459 1460 return True; 1461 1462 elsif Is_Pure_Or_Preelab_Unit (U2) 1463 and then not 1464 Is_Pure_Or_Preelab_Unit (U1) 1465 then 1466 if Debug_Flag_B then 1467 Write_Line (" False: u2 is pure/preelab, u1 is not"); 1468 end if; 1469 1470 return False; 1471 1472 -- Prefer anything else to a waiting body. We want to make bodies wait 1473 -- as long as possible, till we are forced to choose them. 1474 1475 elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then 1476 if Debug_Flag_B then 1477 Write_Line (" False: u1 is waiting body, u2 is not"); 1478 end if; 1479 1480 return False; 1481 1482 elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then 1483 if Debug_Flag_B then 1484 Write_Line (" True: u2 is waiting body, u1 is not"); 1485 end if; 1486 1487 return True; 1488 1489 -- Prefer a spec to a body (this is mandatory) 1490 1491 elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then 1492 if Debug_Flag_B then 1493 Write_Line (" False: u1 is body, u2 is not"); 1494 end if; 1495 1496 return False; 1497 1498 elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then 1499 if Debug_Flag_B then 1500 Write_Line (" True: u2 is body, u1 is not"); 1501 end if; 1502 1503 return True; 1504 1505 -- If both are waiting bodies, then prefer the one whose spec is 1506 -- less recently elaborated. Consider the following: 1507 1508 -- spec of A 1509 -- spec of B 1510 -- body of A or B? 1511 1512 -- The normal waiting body preference would have placed the body of 1513 -- A before the spec of B if it could. Since it could not, there it 1514 -- must be the case that A depends on B. It is therefore a good idea 1515 -- to put the body of B last so that if there is an elaboration order 1516 -- problem, we will find it (that's what pessimistic order is about) 1517 1518 elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then 1519 declare 1520 Result : constant Boolean := 1521 UNR.Table (Corresponding_Spec (U1)).Elab_Position < 1522 UNR.Table (Corresponding_Spec (U2)).Elab_Position; 1523 begin 1524 if Debug_Flag_B then 1525 if Result then 1526 Write_Line (" True: based on waiting body elab positions"); 1527 else 1528 Write_Line (" False: based on waiting body elab positions"); 1529 end if; 1530 end if; 1531 1532 return Result; 1533 end; 1534 end if; 1535 1536 -- Remaining choice rules are disabled by Debug flag -do 1537 1538 if not Debug_Flag_O then 1539 1540 -- The following deal with the case of specs which have been marked 1541 -- as Elaborate_Body_Desirable. In the normal case, we generally want 1542 -- to delay the elaboration of these specs as long as possible, so 1543 -- that bodies have better chance of being elaborated closer to the 1544 -- specs. Pessimistic_Better_Choice as usual wants to do the opposite 1545 -- and elaborate such specs as early as possible. 1546 1547 -- If we have two units, one of which is a spec for which this flag 1548 -- is set, and the other is not, we normally prefer to delay the spec 1549 -- for which the flag is set, so again Pessimistic_Better_Choice does 1550 -- the opposite. 1551 1552 if not UT1.Elaborate_Body_Desirable 1553 and then UT2.Elaborate_Body_Desirable 1554 then 1555 if Debug_Flag_B then 1556 Write_Line (" False: u1 is elab body desirable, u2 is not"); 1557 end if; 1558 1559 return False; 1560 1561 elsif not UT2.Elaborate_Body_Desirable 1562 and then UT1.Elaborate_Body_Desirable 1563 then 1564 if Debug_Flag_B then 1565 Write_Line (" True: u1 is elab body desirable, u2 is not"); 1566 end if; 1567 1568 return True; 1569 1570 -- If we have two specs that are both marked as Elaborate_Body 1571 -- desirable, we normally prefer the one whose body is nearer to 1572 -- being able to be elaborated, based on the Num_Pred count. This 1573 -- helps to ensure bodies are as close to specs as possible. As 1574 -- usual, Pessimistic_Better_Choice does the opposite. 1575 1576 elsif UT1.Elaborate_Body_Desirable 1577 and then UT2.Elaborate_Body_Desirable 1578 then 1579 declare 1580 Result : constant Boolean := 1581 UNR.Table (Corresponding_Body (U1)).Num_Pred >= 1582 UNR.Table (Corresponding_Body (U2)).Num_Pred; 1583 begin 1584 if Debug_Flag_B then 1585 if Result then 1586 Write_Line (" True based on Num_Pred compare"); 1587 else 1588 Write_Line (" False based on Num_Pred compare"); 1589 end if; 1590 end if; 1591 1592 return Result; 1593 end; 1594 end if; 1595 end if; 1596 1597 -- If we fall through, it means that no preference rule applies, so we 1598 -- use alphabetical order to at least give a deterministic result. Since 1599 -- Pessimistic_Better_Choice is in the business of stirring up the 1600 -- order, we will use reverse alphabetical ordering. 1601 1602 if Debug_Flag_B then 1603 Write_Line (" choose on reverse alpha order"); 1604 end if; 1605 1606 return Uname_Less (UT2.Uname, UT1.Uname); 1607 end Pessimistic_Better_Choice; 1608 1609 ---------------- 1610 -- Unit_Id_Of -- 1611 ---------------- 1612 1613 function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is 1614 Info : constant Int := Get_Name_Table_Info (Uname); 1615 begin 1616 pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); 1617 return Unit_Id (Info); 1618 end Unit_Id_Of; 1619 1620 ------------------------ 1621 -- Write_Dependencies -- 1622 ------------------------ 1623 1624 procedure Write_Dependencies is 1625 begin 1626 if not Zero_Formatting then 1627 Write_Eol; 1628 Write_Str (" ELABORATION ORDER DEPENDENCIES"); 1629 Write_Eol; 1630 Write_Eol; 1631 end if; 1632 1633 Info_Prefix_Suppress := True; 1634 1635 for S in Succ_First .. Succ.Last loop 1636 Elab_Error_Msg (S); 1637 end loop; 1638 1639 Info_Prefix_Suppress := False; 1640 1641 if not Zero_Formatting then 1642 Write_Eol; 1643 end if; 1644 end Write_Dependencies; 1645 1646 -------------------------- 1647 -- Write_Elab_All_Chain -- 1648 -------------------------- 1649 1650 procedure Write_Elab_All_Chain (S : Successor_Id) is 1651 ST : constant Successor_Link := Succ.Table (S); 1652 After : constant Unit_Name_Type := Units.Table (ST.After).Uname; 1653 1654 L : Elab_All_Id; 1655 Nam : Unit_Name_Type; 1656 1657 First_Name : Boolean := True; 1658 1659 begin 1660 if ST.Reason in Elab_All .. Elab_All_Desirable then 1661 L := ST.Elab_All_Link; 1662 while L /= No_Elab_All_Link loop 1663 Nam := Elab_All_Entries.Table (L).Needed_By; 1664 Error_Msg_Unit_1 := Nam; 1665 Error_Msg_Output (" $", Info => True); 1666 1667 Get_Name_String (Nam); 1668 1669 if Name_Buffer (Name_Len) = 'b' then 1670 if First_Name then 1671 Error_Msg_Output 1672 (" must be elaborated along with its spec:", 1673 Info => True); 1674 1675 else 1676 Error_Msg_Output 1677 (" which must be elaborated " & 1678 "along with its spec:", 1679 Info => True); 1680 end if; 1681 1682 else 1683 if First_Name then 1684 Error_Msg_Output 1685 (" is withed by:", 1686 Info => True); 1687 1688 else 1689 Error_Msg_Output 1690 (" which is withed by:", 1691 Info => True); 1692 end if; 1693 end if; 1694 1695 First_Name := False; 1696 1697 L := Elab_All_Entries.Table (L).Next_Elab; 1698 end loop; 1699 1700 Error_Msg_Unit_1 := After; 1701 Error_Msg_Output (" $", Info => True); 1702 end if; 1703 end Write_Elab_All_Chain; 1704 1705end Binde; 1706