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