1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- B I N D E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2018, 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 Opt; use Opt; 31with Osint; 32with Output; use Output; 33with Table; 34 35with System.Case_Util; use System.Case_Util; 36with System.HTable; 37with System.OS_Lib; 38 39package body Binde is 40 41 -- We now have Elab_New, a new elaboration-order algorithm. 42 -- 43 -- However, any change to elaboration order can break some programs. 44 -- Therefore, we are keeping the old algorithm in place, to be selected 45 -- by switches. 46 -- 47 -- The new algorithm has the following interesting properties: 48 -- 49 -- * The static and dynamic models use the same elaboration order. The 50 -- static model might get an error, but if it does not, it will use 51 -- the same order as the dynamic model. 52 -- 53 -- * Each SCC (see below) is elaborated together; that is, units from 54 -- different SCCs are not interspersed. 55 -- 56 -- * In particular, this implies that if an SCC contains just a spec and 57 -- the corresponding body, and nothing else, the body will be 58 -- elaborated immediately after the spec. This is expected to result 59 -- in a better elaboration order for most programs, because in this 60 -- case, a call from outside the library unit cannot get ABE. 61 -- 62 -- * Pragmas Elaborate_All (explicit and implicit) are ignored. Instead, 63 -- we behave as if every legal pragma Elaborate_All were present. That 64 -- is, if it would be legal to have "pragma Elaborate_All(Y);" on X, 65 -- then we behave as if such a pragma exists, even if it does not. 66 67 Do_Old : constant Boolean := False; 68 Do_New : constant Boolean := True; 69 -- True to enable the old and new algorithms, respectively. Used for 70 -- debugging/experimentation. 71 72 Doing_New : Boolean := False; 73 -- True if we are currently doing the new algorithm. Print certain 74 -- messages only when doing the "new" elab order algorithm, so we don't get 75 -- duplicates. And use different heuristics in Better_Choice_Optimistic. 76 77 -- The following data structures are used to represent the graph that is 78 -- used to determine the elaboration order (using a topological sort). 79 80 -- The following structures are used to record successors. If B is a 81 -- successor of A in this table, it means that A must be elaborated before 82 -- B is elaborated. For example, if Y (body) says "with X;", then Y (body) 83 -- will be a successor of X (spec), and X (spec) will be a predecessor of 84 -- Y (body). 85 -- 86 -- Note that we store the successors of each unit explicitly. We don't 87 -- store the predecessors, but we store a count of them. 88 -- 89 -- The basic algorithm is to first compute a directed graph of units (type 90 -- Unit_Node_Record, below), with successors as edges. A unit is "ready" 91 -- (to be chosen as the next to be elaborated) if it has no predecessors 92 -- that have not yet been chosen. We use heuristics to decide which of the 93 -- ready units should be elaborated next, and "choose" that one (which 94 -- means we append it to the elaboration-order table). 95 96 type Successor_Id is new Nat; 97 -- Identification of single successor entry 98 99 No_Successor : constant Successor_Id := 0; 100 -- Used to indicate end of list of successors 101 102 type Elab_All_Id is new Nat; 103 -- Identification of Elab_All entry link 104 105 No_Elab_All_Link : constant Elab_All_Id := 0; 106 -- Used to indicate end of list 107 108 -- Succ_Reason indicates the reason for a particular elaboration link 109 110 type Succ_Reason is 111 (Withed, 112 -- After directly with's Before, so the spec of Before must be 113 -- elaborated before After is elaborated. 114 115 Forced, 116 -- Before and After come from a pair of lines in the forced elaboration 117 -- order file. 118 119 Elab, 120 -- After directly mentions Before in a pragma Elaborate, so the body of 121 -- Before must be elaborated before After is elaborated. 122 123 Elab_All, 124 -- After either mentions Before directly in a pragma Elaborate_All, or 125 -- mentions a third unit, X, which itself requires that Before be 126 -- elaborated before unit X is elaborated. The Elab_All_Link list traces 127 -- the dependencies in the latter case. 128 129 Elab_All_Desirable, 130 -- This is just like Elab_All, except that the Elaborate_All was not 131 -- explicitly present in the source, but rather was created by the front 132 -- end, which decided that it was "desirable". 133 134 Elab_Desirable, 135 -- This is just like Elab, except that the Elaborate was not explicitly 136 -- present in the source, but rather was created by the front end, which 137 -- decided that it was "desirable". 138 139 Spec_First); 140 -- After is a body, and Before is the corresponding spec 141 142 -- Successor_Link contains the information for one link 143 144 type Successor_Link is record 145 Before : Unit_Id; 146 -- Predecessor unit 147 148 After : Unit_Id; 149 -- Successor unit 150 151 Next : Successor_Id; 152 -- Next successor on this list 153 154 Reason : Succ_Reason; 155 -- Reason for this link 156 157 Elab_Body : Boolean; 158 -- Set True if this link is needed for the special Elaborate_Body 159 -- processing described below. 160 161 Reason_Unit : Unit_Id; 162 -- For Reason = Elab, or Elab_All or Elab_Desirable, records the unit 163 -- containing the pragma leading to the link. 164 165 Elab_All_Link : Elab_All_Id; 166 -- If Reason = Elab_All or Elab_Desirable, then this points to the 167 -- first element in a list of Elab_All entries that record the with 168 -- chain resulting in this particular dependency. 169 end record; 170 171 -- Note on handling of Elaborate_Body. Basically, if we have a pragma 172 -- Elaborate_Body in a unit, it means that the spec and body have to be 173 -- handled as a single entity from the point of view of determining an 174 -- elaboration order. What we do is to essentially remove the body from 175 -- consideration completely, and transfer all its links (other than the 176 -- spec link) to the spec. Then when the spec gets chosen, we choose the 177 -- body right afterwards. We mark the links that get moved from the body to 178 -- the spec by setting their Elab_Body flag True, so that we can understand 179 -- what is going on. 180 181 Succ_First : constant := 1; 182 183 package Succ is new Table.Table 184 (Table_Component_Type => Successor_Link, 185 Table_Index_Type => Successor_Id, 186 Table_Low_Bound => Succ_First, 187 Table_Initial => 500, 188 Table_Increment => 200, 189 Table_Name => "Succ"); 190 191 -- For the case of Elaborate_All, the following table is used to record 192 -- chains of with relationships that lead to the Elab_All link. These are 193 -- used solely for diagnostic purposes 194 195 type Elab_All_Entry is record 196 Needed_By : Unit_Name_Type; 197 -- Name of unit from which referencing unit was with'ed or otherwise 198 -- needed as a result of Elaborate_All or Elaborate_Desirable. 199 200 Next_Elab : Elab_All_Id; 201 -- Link to next entry on chain (No_Elab_All_Link marks end of list) 202 end record; 203 204 package Elab_All_Entries is new Table.Table 205 (Table_Component_Type => Elab_All_Entry, 206 Table_Index_Type => Elab_All_Id, 207 Table_Low_Bound => 1, 208 Table_Initial => 2000, 209 Table_Increment => 200, 210 Table_Name => "Elab_All_Entries"); 211 212 type Unit_Id_Array_Ptr is access Unit_Id_Array; 213 214 -- A Unit_Node_Record is built for each active unit 215 216 type Unit_Node_Record is record 217 Successors : Successor_Id; 218 -- Pointer to list of links for successor nodes 219 220 Num_Pred : Int; 221 -- Number of predecessors for this unit that have not yet been chosen. 222 -- Normally non-negative, but can go negative in the case of units 223 -- chosen by the diagnose error procedure (when cycles are being removed 224 -- from the graph). 225 226 Nextnp : Unit_Id; 227 -- Forward pointer for list of units with no predecessors 228 229 Visited : Boolean; 230 -- Used in computing transitive closure for Elaborate_All and also in 231 -- locating cycles and paths in the diagnose routines. 232 233 Elab_Position : Nat; 234 -- Initialized to zero. Set non-zero when a unit is chosen and placed in 235 -- the elaboration order. The value represents the ordinal position in 236 -- the elaboration order. 237 238 -- The following are for Elab_New. We compute the strongly connected 239 -- components (SCCs) of the directed graph of units. The edges are the 240 -- Successors, which do not include pragmas Elaborate_All (explicit or 241 -- implicit) in Elab_New. In addition, we assume there is a edge 242 -- pointing from a body to its corresponding spec; this edge is not 243 -- included in Successors, because of course a spec is elaborated BEFORE 244 -- its body, not after. 245 246 SCC_Root : Unit_Id; 247 -- Each unit points to the root of its SCC, which is just an arbitrary 248 -- member of the SCC. Two units are in the same SCC if and only if their 249 -- SCC_Roots are equal. U is the root of its SCC if and only if 250 -- SCC(U)=U. 251 252 Nodes : Unit_Id_Array_Ptr; 253 -- Present only in the root of an SCC. This is the set of units in the 254 -- SCC, in no particular order. 255 256 SCC_Num_Pred : Int; 257 -- Present only in the root of an SCC. This is the number of predecessor 258 -- units of the SCC that are in other SCCs, and that have not yet been 259 -- chosen. 260 261 Validate_Seen : Boolean := False; 262 -- See procedure Validate below 263 end record; 264 265 package UNR is new Table.Table 266 (Table_Component_Type => Unit_Node_Record, 267 Table_Index_Type => Unit_Id, 268 Table_Low_Bound => First_Unit_Entry, 269 Table_Initial => 500, 270 Table_Increment => 200, 271 Table_Name => "UNR"); 272 273 No_Pred : Unit_Id; 274 -- Head of list of items with no predecessors 275 276 Num_Left : Int; 277 -- Number of entries not yet dealt with 278 279 Cur_Unit : Unit_Id; 280 -- Current unit, set by Gather_Dependencies, and picked up in Build_Link to 281 -- set the Reason_Unit field of the created dependency link. 282 283 Num_Chosen : Nat; 284 -- Number of units chosen in the elaboration order so far 285 286 Diagnose_Elaboration_Problem_Called : Boolean := False; 287 -- True if Diagnose_Elaboration_Problem was called. Used in an assertion. 288 289 ----------------------- 290 -- Local Subprograms -- 291 ----------------------- 292 293 function Debug_Flag_Older return Boolean; 294 function Debug_Flag_Old return Boolean; 295 -- True if debug flags select the old or older algorithms. Pretty much any 296 -- change to elaboration order can break some programs. For example, 297 -- programs can depend on elaboration order even without failing 298 -- access-before-elaboration checks. A trivial example is a program that 299 -- prints text during elaboration. Therefore, we have flags to revert to 300 -- the old(er) algorithms. 301 302 procedure Validate (Order : Unit_Id_Array; Doing_New : Boolean); 303 -- Assert that certain properties are true 304 305 function Better_Choice_Optimistic 306 (U1 : Unit_Id; 307 U2 : Unit_Id) return Boolean; 308 -- U1 and U2 are both permitted candidates for selection as the next unit 309 -- to be elaborated. This function determines whether U1 is a better choice 310 -- than U2, i.e. should be elaborated in preference to U2, based on a set 311 -- of heuristics that establish a friendly and predictable order (see body 312 -- for details). The result is True if U1 is a better choice than U2, and 313 -- False if it is a worse choice, or there is no preference between them. 314 315 function Better_Choice_Pessimistic 316 (U1 : Unit_Id; 317 U2 : Unit_Id) return Boolean; 318 -- This is like Better_Choice_Optimistic, and has the same interface, but 319 -- returns true if U1 is a worse choice than U2 in the sense of the -p 320 -- (pessimistic elaboration order) switch. We still have to obey Ada rules, 321 -- so it is not quite the direct inverse of Better_Choice_Optimistic. 322 323 function Better_Choice (U1 : Unit_Id; U2 : Unit_Id) return Boolean; 324 -- Calls Better_Choice_Optimistic or Better_Choice_Pessimistic as 325 -- appropriate. Also takes care of the U2 = No_Unit_Id case. 326 327 procedure Build_Link 328 (Before : Unit_Id; 329 After : Unit_Id; 330 R : Succ_Reason; 331 Ea_Id : Elab_All_Id := No_Elab_All_Link); 332 -- Establish a successor link, Before must be elaborated before After, and 333 -- the reason for the link is R. Ea_Id is the contents to be placed in the 334 -- Elab_All_Link of the entry. 335 336 procedure Choose 337 (Elab_Order : in out Unit_Id_Table; 338 Chosen : Unit_Id; 339 Msg : String); 340 -- Chosen is the next entry chosen in the elaboration order. This procedure 341 -- updates all data structures appropriately. 342 343 function Corresponding_Body (U : Unit_Id) return Unit_Id; 344 pragma Inline (Corresponding_Body); 345 -- Given a unit that is a spec for which there is a separate body, return 346 -- the unit id of the body. It is an error to call this routine with a unit 347 -- that is not a spec, or that does not have a separate body. 348 349 function Corresponding_Spec (U : Unit_Id) return Unit_Id; 350 pragma Inline (Corresponding_Spec); 351 -- Given a unit that is a body for which there is a separate spec, return 352 -- the unit id of the spec. It is an error to call this routine with a unit 353 -- that is not a body, or that does not have a separate spec. 354 355 procedure Diagnose_Elaboration_Problem 356 (Elab_Order : in out Unit_Id_Table); 357 pragma No_Return (Diagnose_Elaboration_Problem); 358 -- Called when no elaboration order can be found. Outputs an appropriate 359 -- diagnosis of the problem, and then abandons the bind. 360 361 procedure Elab_All_Links 362 (Before : Unit_Id; 363 After : Unit_Id; 364 Reason : Succ_Reason; 365 Link : Elab_All_Id); 366 -- Used to compute the transitive closure of elaboration links for an 367 -- Elaborate_All pragma (Reason = Elab_All) or for an indication of 368 -- Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has a 369 -- pragma Elaborate_All or the front end has determined that a reference 370 -- probably requires Elaborate_All, and unit Before must be previously 371 -- elaborated. First a link is built making sure that unit Before is 372 -- elaborated before After, then a recursive call ensures that we also 373 -- build links for any units needed by Before (i.e. these units must/should 374 -- also be elaborated before After). Link is used to build a chain of 375 -- Elab_All_Entries to explain the reason for a link. The value passed is 376 -- the chain so far. 377 378 procedure Elab_Error_Msg (S : Successor_Id); 379 -- Given a successor link, outputs an error message of the form 380 -- "$ must be elaborated before $ ..." where ... is the reason. 381 382 procedure Force_Elab_Order; 383 -- Gather dependencies from the forced elaboration order file (-f switch) 384 385 procedure Gather_Dependencies; 386 -- Compute dependencies, building the Succ and UNR tables 387 388 procedure Init; 389 -- Initialize global data structures in this package body 390 391 function Is_Body_Unit (U : Unit_Id) return Boolean; 392 pragma Inline (Is_Body_Unit); 393 -- Determines if given unit is a body 394 395 function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean; 396 -- Returns True if corresponding unit is Pure or Preelaborate. Includes 397 -- dealing with testing flags on spec if it is given a body. 398 399 function Is_Waiting_Body (U : Unit_Id) return Boolean; 400 pragma Inline (Is_Waiting_Body); 401 -- Determines if U is a waiting body, defined as a body that has 402 -- not been elaborated, but whose spec has been elaborated. 403 404 function Make_Elab_All_Entry 405 (Unam : Unit_Name_Type; 406 Link : Elab_All_Id) return Elab_All_Id; 407 -- Make an Elab_All_Entries table entry with the given Unam and Link 408 409 function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id; 410 -- This function uses the Info field set in the names table to obtain 411 -- the unit Id of a unit, given its name id value. 412 413 procedure Write_Closure (Order : Unit_Id_Array); 414 -- Write the closure. This is for the -R and -Ra switches, "list closure 415 -- display". 416 417 procedure Write_Dependencies; 418 -- Write out dependencies (called only if appropriate option is set) 419 420 procedure Write_Elab_All_Chain (S : Successor_Id); 421 -- If the reason for the link S is Elaborate_All or Elaborate_Desirable, 422 -- then this routine will output the "needed by" explanation chain. 423 424 procedure Write_Elab_Order (Order : Unit_Id_Array; Title : String); 425 -- Display elaboration order. This is for the -l switch. Title is a heading 426 -- to print; an empty string is passed to indicate Zero_Formatting. 427 428 package Elab_New is 429 430 -- Implementation of the new algorithm 431 432 procedure Write_SCC (U : Unit_Id); 433 -- Write the unit names of the units in the SCC in which U lives 434 435 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table); 436 437 Elab_Cycle_Found : Boolean := False; 438 -- Set True if Find_Elab_Order found a cycle (usually an illegal pragma 439 -- Elaborate_All, explicit or implicit). 440 441 function SCC (U : Unit_Id) return Unit_Id; 442 -- The root of the strongly connected component containing U 443 444 function SCC_Num_Pred (U : Unit_Id) return Int; 445 -- The SCC_Num_Pred of the SCC in which U lives 446 447 function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr; 448 -- The nodes of the strongly connected component containing U 449 450 end Elab_New; 451 452 use Elab_New; 453 454 package Elab_Old is 455 456 -- Implementation of the old algorithm 457 458 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table); 459 460 end Elab_Old; 461 462 -- Most of the code is shared between old and new; such code is outside 463 -- packages Elab_Old and Elab_New. 464 465 ------------------- 466 -- Better_Choice -- 467 ------------------- 468 469 function Better_Choice (U1 : Unit_Id; U2 : Unit_Id) return Boolean is 470 pragma Assert (U1 /= No_Unit_Id); 471 begin 472 if U2 = No_Unit_Id then 473 return True; 474 end if; 475 476 if Pessimistic_Elab_Order then 477 return Better_Choice_Pessimistic (U1, U2); 478 else 479 return Better_Choice_Optimistic (U1, U2); 480 end if; 481 end Better_Choice; 482 483 ------------------------------ 484 -- Better_Choice_Optimistic -- 485 ------------------------------ 486 487 function Better_Choice_Optimistic 488 (U1 : Unit_Id; 489 U2 : Unit_Id) return Boolean 490 is 491 UT1 : Unit_Record renames Units.Table (U1); 492 UT2 : Unit_Record renames Units.Table (U2); 493 494 begin 495 if Debug_Flag_B then 496 Write_Str ("Better_Choice_Optimistic ("); 497 Write_Unit_Name (UT1.Uname); 498 Write_Str (", "); 499 Write_Unit_Name (UT2.Uname); 500 Write_Line (")"); 501 end if; 502 503 -- Note: the checks here are applied in sequence, and the ordering is 504 -- significant (i.e. the more important criteria are applied first). 505 506 -- Prefer a waiting body to one that is not a waiting body 507 508 if Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then 509 if Debug_Flag_B then 510 Write_Line (" True: u1 is waiting body, u2 is not"); 511 end if; 512 513 return True; 514 515 elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then 516 if Debug_Flag_B then 517 Write_Line (" False: u2 is waiting body, u1 is not"); 518 end if; 519 520 return False; 521 522 -- Prefer a predefined unit to a non-predefined unit 523 524 elsif UT1.Predefined and then not UT2.Predefined then 525 if Debug_Flag_B then 526 Write_Line (" True: u1 is predefined, u2 is not"); 527 end if; 528 529 return True; 530 531 elsif UT2.Predefined and then not UT1.Predefined then 532 if Debug_Flag_B then 533 Write_Line (" False: u2 is predefined, u1 is not"); 534 end if; 535 536 return False; 537 538 -- Prefer an internal unit to a non-internal unit 539 540 elsif UT1.Internal and then not UT2.Internal then 541 if Debug_Flag_B then 542 Write_Line (" True: u1 is internal, u2 is not"); 543 end if; 544 return True; 545 546 elsif UT2.Internal and then not UT1.Internal then 547 if Debug_Flag_B then 548 Write_Line (" False: u2 is internal, u1 is not"); 549 end if; 550 551 return False; 552 553 -- Prefer a pure or preelaborated unit to one that is not. Pure should 554 -- come before preelaborated. 555 556 elsif Is_Pure_Or_Preelab_Unit (U1) 557 and then not 558 Is_Pure_Or_Preelab_Unit (U2) 559 then 560 if Debug_Flag_B then 561 Write_Line (" True: u1 is pure/preelab, u2 is not"); 562 end if; 563 564 return True; 565 566 elsif Is_Pure_Or_Preelab_Unit (U2) 567 and then not 568 Is_Pure_Or_Preelab_Unit (U1) 569 then 570 if Debug_Flag_B then 571 Write_Line (" False: u2 is pure/preelab, u1 is not"); 572 end if; 573 574 return False; 575 576 -- Prefer a body to a spec 577 578 elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then 579 if Debug_Flag_B then 580 Write_Line (" True: u1 is body, u2 is not"); 581 end if; 582 583 return True; 584 585 elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then 586 if Debug_Flag_B then 587 Write_Line (" False: u2 is body, u1 is not"); 588 end if; 589 590 return False; 591 592 -- If both are waiting bodies, then prefer the one whose spec is more 593 -- recently elaborated. Consider the following: 594 595 -- spec of A 596 -- spec of B 597 -- body of A or B? 598 599 -- The normal waiting body preference would have placed the body of A 600 -- before the spec of B if it could. Since it could not, then it must be 601 -- the case that A depends on B. It is therefore a good idea to put the 602 -- body of B first. 603 604 elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then 605 declare 606 Result : constant Boolean := 607 UNR.Table (Corresponding_Spec (U1)).Elab_Position > 608 UNR.Table (Corresponding_Spec (U2)).Elab_Position; 609 begin 610 if Debug_Flag_B then 611 if Result then 612 Write_Line (" True: based on waiting body elab positions"); 613 else 614 Write_Line (" False: based on waiting body elab positions"); 615 end if; 616 end if; 617 618 return Result; 619 end; 620 end if; 621 622 -- Remaining choice rules are disabled by Debug flag -do 623 624 if not Debug_Flag_Older then 625 626 -- The following deal with the case of specs that have been marked 627 -- as Elaborate_Body_Desirable. We generally want to delay these 628 -- specs as long as possible, so that the bodies have a better chance 629 -- of being elaborated closer to the specs. 630 631 -- If we have two units, one of which is a spec for which this flag 632 -- is set, and the other is not, we prefer to delay the spec for 633 -- which the flag is set. 634 635 if not UT1.Elaborate_Body_Desirable 636 and then UT2.Elaborate_Body_Desirable 637 then 638 if Debug_Flag_B then 639 Write_Line (" True: u1 is elab body desirable, u2 is not"); 640 end if; 641 642 return True; 643 644 elsif not UT2.Elaborate_Body_Desirable 645 and then UT1.Elaborate_Body_Desirable 646 then 647 if Debug_Flag_B then 648 Write_Line (" False: u1 is elab body desirable, u2 is not"); 649 end if; 650 651 return False; 652 653 -- If we have two specs that are both marked as Elaborate_Body 654 -- desirable, we prefer the one whose body is nearer to being able 655 -- to be elaborated, based on the Num_Pred count. This helps to 656 -- ensure bodies are as close to specs as possible. 657 658 elsif UT1.Elaborate_Body_Desirable 659 and then UT2.Elaborate_Body_Desirable 660 then 661 declare 662 Result : constant Boolean := 663 UNR.Table (Corresponding_Body (U1)).Num_Pred < 664 UNR.Table (Corresponding_Body (U2)).Num_Pred; 665 begin 666 if Debug_Flag_B then 667 if Result then 668 Write_Line (" True based on Num_Pred compare"); 669 else 670 Write_Line (" False based on Num_Pred compare"); 671 end if; 672 end if; 673 674 return Result; 675 end; 676 end if; 677 end if; 678 679 -- If we have two specs in the same SCC, choose the one whose body is 680 -- closer to being ready. 681 682 if Doing_New 683 and then SCC (U1) = SCC (U2) 684 and then Units.Table (U1).Utype = Is_Spec 685 and then Units.Table (U2).Utype = Is_Spec 686 and then UNR.Table (Corresponding_Body (U1)).Num_Pred /= 687 UNR.Table (Corresponding_Body (U2)).Num_Pred 688 then 689 if UNR.Table (Corresponding_Body (U1)).Num_Pred < 690 UNR.Table (Corresponding_Body (U2)).Num_Pred 691 then 692 if Debug_Flag_B then 693 Write_Str (" True: same SCC; "); 694 Write_Int (UNR.Table (Corresponding_Body (U1)).Num_Pred); 695 Write_Str (" < "); 696 Write_Int (UNR.Table (Corresponding_Body (U2)).Num_Pred); 697 Write_Eol; 698 end if; 699 700 return True; 701 else 702 if Debug_Flag_B then 703 Write_Str (" False: same SCC; "); 704 Write_Int (UNR.Table (Corresponding_Body (U1)).Num_Pred); 705 Write_Str (" > "); 706 Write_Int (UNR.Table (Corresponding_Body (U2)).Num_Pred); 707 Write_Eol; 708 end if; 709 710 return False; 711 end if; 712 end if; 713 714 -- If we fall through, it means that no preference rule applies, so we 715 -- use alphabetical order to at least give a deterministic result. 716 717 if Debug_Flag_B then 718 Write_Line (" choose on alpha order"); 719 end if; 720 721 return Uname_Less (UT1.Uname, UT2.Uname); 722 end Better_Choice_Optimistic; 723 724 ------------------------------- 725 -- Better_Choice_Pessimistic -- 726 ------------------------------- 727 728 function Better_Choice_Pessimistic 729 (U1 : Unit_Id; 730 U2 : Unit_Id) return Boolean 731 is 732 UT1 : Unit_Record renames Units.Table (U1); 733 UT2 : Unit_Record renames Units.Table (U2); 734 735 begin 736 if Debug_Flag_B then 737 Write_Str ("Better_Choice_Pessimistic ("); 738 Write_Unit_Name (UT1.Uname); 739 Write_Str (", "); 740 Write_Unit_Name (UT2.Uname); 741 Write_Line (")"); 742 end if; 743 744 -- Note: the checks here are applied in sequence, and the ordering is 745 -- significant (i.e. the more important criteria are applied first). 746 747 -- If either unit is predefined or internal, then we use the normal 748 -- Better_Choice_Optimistic rule, since we don't want to disturb the 749 -- elaboration rules of the language with -p; same treatment for 750 -- Pure/Preelab. 751 752 -- Prefer a predefined unit to a non-predefined unit 753 754 if UT1.Predefined and then not UT2.Predefined then 755 if Debug_Flag_B then 756 Write_Line (" True: u1 is predefined, u2 is not"); 757 end if; 758 759 return True; 760 761 elsif UT2.Predefined and then not UT1.Predefined then 762 if Debug_Flag_B then 763 Write_Line (" False: u2 is predefined, u1 is not"); 764 end if; 765 766 return False; 767 768 -- Prefer an internal unit to a non-internal unit 769 770 elsif UT1.Internal and then not UT2.Internal then 771 if Debug_Flag_B then 772 Write_Line (" True: u1 is internal, u2 is not"); 773 end if; 774 775 return True; 776 777 elsif UT2.Internal and then not UT1.Internal then 778 if Debug_Flag_B then 779 Write_Line (" False: u2 is internal, u1 is not"); 780 end if; 781 782 return False; 783 784 -- Prefer a pure or preelaborated unit to one that is not 785 786 elsif Is_Pure_Or_Preelab_Unit (U1) 787 and then not 788 Is_Pure_Or_Preelab_Unit (U2) 789 then 790 if Debug_Flag_B then 791 Write_Line (" True: u1 is pure/preelab, u2 is not"); 792 end if; 793 794 return True; 795 796 elsif Is_Pure_Or_Preelab_Unit (U2) 797 and then not 798 Is_Pure_Or_Preelab_Unit (U1) 799 then 800 if Debug_Flag_B then 801 Write_Line (" False: u2 is pure/preelab, u1 is not"); 802 end if; 803 804 return False; 805 806 -- Prefer anything else to a waiting body. We want to make bodies wait 807 -- as long as possible, till we are forced to choose them. 808 809 elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then 810 if Debug_Flag_B then 811 Write_Line (" False: u1 is waiting body, u2 is not"); 812 end if; 813 814 return False; 815 816 elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then 817 if Debug_Flag_B then 818 Write_Line (" True: u2 is waiting body, u1 is not"); 819 end if; 820 821 return True; 822 823 -- Prefer a spec to a body (this is mandatory) 824 825 elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then 826 if Debug_Flag_B then 827 Write_Line (" False: u1 is body, u2 is not"); 828 end if; 829 830 return False; 831 832 elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then 833 if Debug_Flag_B then 834 Write_Line (" True: u2 is body, u1 is not"); 835 end if; 836 837 return True; 838 839 -- If both are waiting bodies, then prefer the one whose spec is less 840 -- recently elaborated. Consider the following: 841 842 -- spec of A 843 -- spec of B 844 -- body of A or B? 845 846 -- The normal waiting body preference would have placed the body of A 847 -- before the spec of B if it could. Since it could not, then it must be 848 -- the case that A depends on B. It is therefore a good idea to put the 849 -- body of B last so that if there is an elaboration order problem, we 850 -- will find it (that's what pessimistic order is about). 851 852 elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then 853 declare 854 Result : constant Boolean := 855 UNR.Table (Corresponding_Spec (U1)).Elab_Position < 856 UNR.Table (Corresponding_Spec (U2)).Elab_Position; 857 begin 858 if Debug_Flag_B then 859 if Result then 860 Write_Line (" True: based on waiting body elab positions"); 861 else 862 Write_Line (" False: based on waiting body elab positions"); 863 end if; 864 end if; 865 866 return Result; 867 end; 868 end if; 869 870 -- Remaining choice rules are disabled by Debug flag -do 871 872 if not Debug_Flag_Older then 873 874 -- The following deal with the case of specs that have been marked as 875 -- Elaborate_Body_Desirable. In the normal case, we generally want to 876 -- delay the elaboration of these specs as long as possible, so that 877 -- bodies have better chance of being elaborated closer to the specs. 878 -- Better_Choice_Pessimistic as usual wants to do the opposite and 879 -- elaborate such specs as early as possible. 880 881 -- If we have two units, one of which is a spec for which this flag 882 -- is set, and the other is not, we normally prefer to delay the spec 883 -- for which the flag is set, so again Better_Choice_Pessimistic does 884 -- the opposite. 885 886 if not UT1.Elaborate_Body_Desirable 887 and then UT2.Elaborate_Body_Desirable 888 then 889 if Debug_Flag_B then 890 Write_Line (" False: u1 is elab body desirable, u2 is not"); 891 end if; 892 893 return False; 894 895 elsif not UT2.Elaborate_Body_Desirable 896 and then UT1.Elaborate_Body_Desirable 897 then 898 if Debug_Flag_B then 899 Write_Line (" True: u1 is elab body desirable, u2 is not"); 900 end if; 901 902 return True; 903 904 -- If we have two specs that are both marked as Elaborate_Body 905 -- desirable, we normally prefer the one whose body is nearer to 906 -- being able to be elaborated, based on the Num_Pred count. This 907 -- helps to ensure bodies are as close to specs as possible. As 908 -- usual, Better_Choice_Pessimistic does the opposite. 909 910 elsif UT1.Elaborate_Body_Desirable 911 and then UT2.Elaborate_Body_Desirable 912 then 913 declare 914 Result : constant Boolean := 915 UNR.Table (Corresponding_Body (U1)).Num_Pred >= 916 UNR.Table (Corresponding_Body (U2)).Num_Pred; 917 begin 918 if Debug_Flag_B then 919 if Result then 920 Write_Line (" True based on Num_Pred compare"); 921 else 922 Write_Line (" False based on Num_Pred compare"); 923 end if; 924 end if; 925 926 return Result; 927 end; 928 end if; 929 end if; 930 931 -- If we fall through, it means that no preference rule applies, so we 932 -- use alphabetical order to at least give a deterministic result. Since 933 -- Better_Choice_Pessimistic is in the business of stirring up the 934 -- order, we will use reverse alphabetical ordering. 935 936 if Debug_Flag_B then 937 Write_Line (" choose on reverse alpha order"); 938 end if; 939 940 return Uname_Less (UT2.Uname, UT1.Uname); 941 end Better_Choice_Pessimistic; 942 943 ---------------- 944 -- Build_Link -- 945 ---------------- 946 947 procedure Build_Link 948 (Before : Unit_Id; 949 After : Unit_Id; 950 R : Succ_Reason; 951 Ea_Id : Elab_All_Id := No_Elab_All_Link) 952 is 953 Cspec : Unit_Id; 954 955 begin 956 Succ.Append 957 ((Before => Before, 958 After => No_Unit_Id, -- filled in below 959 Next => UNR.Table (Before).Successors, 960 Reason => R, 961 Elab_Body => False, -- set correctly below 962 Reason_Unit => Cur_Unit, 963 Elab_All_Link => Ea_Id)); 964 UNR.Table (Before).Successors := Succ.Last; 965 966 -- Deal with special Elab_Body case. If the After of this link is 967 -- a body whose spec has Elaborate_All set, and this is not the link 968 -- directly from the body to the spec, then we make the After of the 969 -- link reference its spec instead, marking the link appropriately. 970 971 if Units.Table (After).Utype = Is_Body then 972 Cspec := Corresponding_Spec (After); 973 974 if Units.Table (Cspec).Elaborate_Body 975 and then Cspec /= Before 976 then 977 Succ.Table (Succ.Last).After := Cspec; 978 Succ.Table (Succ.Last).Elab_Body := True; 979 UNR.Table (Cspec).Num_Pred := UNR.Table (Cspec).Num_Pred + 1; 980 return; 981 end if; 982 end if; 983 984 -- Fall through on normal case 985 986 Succ.Table (Succ.Last).After := After; 987 Succ.Table (Succ.Last).Elab_Body := False; 988 UNR.Table (After).Num_Pred := UNR.Table (After).Num_Pred + 1; 989 end Build_Link; 990 991 ------------ 992 -- Choose -- 993 ------------ 994 995 procedure Choose 996 (Elab_Order : in out Unit_Id_Table; 997 Chosen : Unit_Id; 998 Msg : String) 999 is 1000 pragma Assert (Chosen /= No_Unit_Id); 1001 S : Successor_Id; 1002 U : Unit_Id; 1003 1004 begin 1005 if Debug_Flag_C then 1006 Write_Str ("Choosing Unit "); 1007 Write_Unit_Name (Units.Table (Chosen).Uname); 1008 Write_Str (Msg); 1009 end if; 1010 1011 -- We shouldn't be choosing something with unelaborated predecessors, 1012 -- and we shouldn't call this twice on the same unit. But that's not 1013 -- true when this is called from Diagnose_Elaboration_Problem. 1014 1015 if Errors_Detected = 0 then 1016 pragma Assert (UNR.Table (Chosen).Num_Pred = 0); 1017 pragma Assert (UNR.Table (Chosen).Elab_Position = 0); 1018 pragma Assert (not Doing_New or else SCC_Num_Pred (Chosen) = 0); 1019 null; 1020 end if; 1021 1022 -- Add to elaboration order. Note that units having no elaboration code 1023 -- are not treated specially yet. The special casing of this is in 1024 -- Bindgen, where Gen_Elab_Calls skips over them. Meanwhile we need them 1025 -- here, because the object file list is also driven by the contents of 1026 -- the Elab_Order table. 1027 1028 Append (Elab_Order, Chosen); 1029 1030 -- Remove from No_Pred list. This is a little inefficient and may be we 1031 -- should doubly link the list, but it will do for now. 1032 1033 if No_Pred = Chosen then 1034 No_Pred := UNR.Table (Chosen).Nextnp; 1035 else 1036 U := No_Pred; 1037 while U /= No_Unit_Id loop 1038 if UNR.Table (U).Nextnp = Chosen then 1039 UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp; 1040 goto Done_Removal; 1041 end if; 1042 1043 U := UNR.Table (U).Nextnp; 1044 end loop; 1045 1046 -- Here if we didn't find it on the No_Pred list. This can happen 1047 -- only in calls from the Diagnose_Elaboration_Problem routine, 1048 -- where cycles are being removed arbitrarily from the graph. 1049 1050 pragma Assert (Errors_Detected > 0); 1051 <<Done_Removal>> null; 1052 end if; 1053 1054 -- For all successors, decrement the number of predecessors, and if it 1055 -- becomes zero, then add to no-predecessor list. 1056 1057 S := UNR.Table (Chosen).Successors; 1058 while S /= No_Successor loop 1059 U := Succ.Table (S).After; 1060 UNR.Table (U).Num_Pred := UNR.Table (U).Num_Pred - 1; 1061 1062 if Debug_Flag_N then 1063 Write_Str (" decrementing Num_Pred for unit "); 1064 Write_Unit_Name (Units.Table (U).Uname); 1065 Write_Str (" new value = "); 1066 Write_Int (UNR.Table (U).Num_Pred); 1067 Write_Eol; 1068 end if; 1069 1070 if UNR.Table (U).Num_Pred = 0 then 1071 UNR.Table (U).Nextnp := No_Pred; 1072 No_Pred := U; 1073 end if; 1074 1075 if Doing_New and then SCC (U) /= SCC (Chosen) then 1076 UNR.Table (SCC (U)).SCC_Num_Pred := 1077 UNR.Table (SCC (U)).SCC_Num_Pred - 1; 1078 1079 if Debug_Flag_N then 1080 Write_Str (" decrementing SCC_Num_Pred for unit "); 1081 Write_Unit_Name (Units.Table (U).Uname); 1082 Write_Str (" new value = "); 1083 Write_Int (SCC_Num_Pred (U)); 1084 Write_Eol; 1085 end if; 1086 end if; 1087 1088 S := Succ.Table (S).Next; 1089 end loop; 1090 1091 -- All done, adjust number of units left count and set elaboration pos 1092 1093 Num_Left := Num_Left - 1; 1094 Num_Chosen := Num_Chosen + 1; 1095 1096 pragma Assert 1097 (Errors_Detected > 0 or else Num_Chosen = Last (Elab_Order)); 1098 pragma Assert (Units.Last = UNR.Last); 1099 pragma Assert (Num_Chosen + Num_Left = Int (UNR.Last)); 1100 1101 if Debug_Flag_C then 1102 Write_Str (" "); 1103 Write_Int (Int (Num_Chosen)); 1104 Write_Str ("+"); 1105 Write_Int (Num_Left); 1106 Write_Str ("="); 1107 Write_Int (Int (UNR.Last)); 1108 Write_Eol; 1109 end if; 1110 1111 UNR.Table (Chosen).Elab_Position := Num_Chosen; 1112 1113 -- If we just chose a spec with Elaborate_Body set, then we must 1114 -- immediately elaborate the body, before any other units. 1115 1116 if Units.Table (Chosen).Elaborate_Body then 1117 1118 -- If the unit is a spec only, then there is no body. This is a bit 1119 -- odd given that Elaborate_Body is here, but it is valid in an RCI 1120 -- unit, where we only have the interface in the stub bind. 1121 1122 if Units.Table (Chosen).Utype = Is_Spec_Only 1123 and then Units.Table (Chosen).RCI 1124 then 1125 null; 1126 else 1127 Choose 1128 (Elab_Order => Elab_Order, 1129 Chosen => Corresponding_Body (Chosen), 1130 Msg => " [Elaborate_Body]"); 1131 end if; 1132 end if; 1133 end Choose; 1134 1135 ------------------------ 1136 -- Corresponding_Body -- 1137 ------------------------ 1138 1139 -- Currently if the body and spec are separate, then they appear as two 1140 -- separate units in the same ALI file, with the body appearing first and 1141 -- the spec appearing second. 1142 1143 function Corresponding_Body (U : Unit_Id) return Unit_Id is 1144 begin 1145 pragma Assert (Units.Table (U).Utype = Is_Spec); 1146 return U - 1; 1147 end Corresponding_Body; 1148 1149 ------------------------ 1150 -- Corresponding_Spec -- 1151 ------------------------ 1152 1153 -- Currently if the body and spec are separate, then they appear as two 1154 -- separate units in the same ALI file, with the body appearing first and 1155 -- the spec appearing second. 1156 1157 function Corresponding_Spec (U : Unit_Id) return Unit_Id is 1158 begin 1159 pragma Assert (Units.Table (U).Utype = Is_Body); 1160 return U + 1; 1161 end Corresponding_Spec; 1162 1163 -------------------- 1164 -- Debug_Flag_Old -- 1165 -------------------- 1166 1167 function Debug_Flag_Old return Boolean is 1168 begin 1169 -- If the user specified both flags, we want to use the older algorithm, 1170 -- rather than some confusing mix of the two. 1171 1172 return Debug_Flag_P and not Debug_Flag_O; 1173 end Debug_Flag_Old; 1174 1175 ---------------------- 1176 -- Debug_Flag_Older -- 1177 ---------------------- 1178 1179 function Debug_Flag_Older return Boolean is 1180 begin 1181 return Debug_Flag_O; 1182 end Debug_Flag_Older; 1183 1184 ---------------------------------- 1185 -- Diagnose_Elaboration_Problem -- 1186 ---------------------------------- 1187 1188 procedure Diagnose_Elaboration_Problem 1189 (Elab_Order : in out Unit_Id_Table) 1190 is 1191 function Find_Path 1192 (Ufrom : Unit_Id; 1193 Uto : Unit_Id; 1194 ML : Nat) return Boolean; 1195 -- Recursive routine used to find a path from node Ufrom to node Uto. 1196 -- If a path exists, returns True and outputs an appropriate set of 1197 -- error messages giving the path. Also calls Choose for each of the 1198 -- nodes so that they get removed from the remaining set. There are 1199 -- two cases of calls, either Ufrom = Uto for an attempt to find a 1200 -- cycle, or Ufrom is a spec and Uto the corresponding body for the 1201 -- case of an unsatisfiable Elaborate_Body pragma. ML is the minimum 1202 -- acceptable length for a path. 1203 1204 --------------- 1205 -- Find_Path -- 1206 --------------- 1207 1208 function Find_Path 1209 (Ufrom : Unit_Id; 1210 Uto : Unit_Id; 1211 ML : Nat) return Boolean 1212 is 1213 function Find_Link (U : Unit_Id; PL : Nat) return Boolean; 1214 -- This is the inner recursive routine, it determines if a path 1215 -- exists from U to Uto, and if so returns True and outputs the 1216 -- appropriate set of error messages. PL is the path length 1217 1218 --------------- 1219 -- Find_Link -- 1220 --------------- 1221 1222 function Find_Link (U : Unit_Id; PL : Nat) return Boolean is 1223 S : Successor_Id; 1224 1225 begin 1226 -- Recursion ends if we are at terminating node and the path is 1227 -- sufficiently long, generate error message and return True. 1228 1229 if U = Uto and then PL >= ML then 1230 Choose (Elab_Order, U, " [Find_Link: base]"); 1231 return True; 1232 1233 -- All done if already visited 1234 1235 elsif UNR.Table (U).Visited then 1236 return False; 1237 1238 -- Otherwise mark as visited and look at all successors 1239 1240 else 1241 UNR.Table (U).Visited := True; 1242 1243 S := UNR.Table (U).Successors; 1244 while S /= No_Successor loop 1245 if Find_Link (Succ.Table (S).After, PL + 1) then 1246 Elab_Error_Msg (S); 1247 Choose (Elab_Order, U, " [Find_Link: recursive]"); 1248 return True; 1249 end if; 1250 1251 S := Succ.Table (S).Next; 1252 end loop; 1253 1254 -- Falling through means this does not lead to a path 1255 1256 return False; 1257 end if; 1258 end Find_Link; 1259 1260 -- Start of processing for Find_Path 1261 1262 begin 1263 -- Initialize all non-chosen nodes to not visited yet 1264 1265 for U in Units.First .. Units.Last loop 1266 UNR.Table (U).Visited := UNR.Table (U).Elab_Position /= 0; 1267 end loop; 1268 1269 -- Now try to find the path 1270 1271 return Find_Link (Ufrom, 0); 1272 end Find_Path; 1273 1274 -- Start of processing for Diagnose_Elaboration_Problem 1275 1276 begin 1277 Diagnose_Elaboration_Problem_Called := True; 1278 Set_Standard_Error; 1279 1280 -- Output state of things if debug flag N set 1281 1282 if Debug_Flag_N then 1283 declare 1284 NP : Int; 1285 1286 begin 1287 Write_Eol; 1288 Write_Eol; 1289 Write_Line ("Diagnose_Elaboration_Problem called"); 1290 Write_Line ("List of remaining unchosen units and predecessors"); 1291 1292 for U in Units.First .. Units.Last loop 1293 if UNR.Table (U).Elab_Position = 0 then 1294 NP := UNR.Table (U).Num_Pred; 1295 Write_Eol; 1296 Write_Str (" Unchosen unit: #"); 1297 Write_Int (Int (U)); 1298 Write_Str (" "); 1299 Write_Unit_Name (Units.Table (U).Uname); 1300 Write_Str (" (Num_Pred = "); 1301 Write_Int (NP); 1302 Write_Line (")"); 1303 1304 if NP = 0 then 1305 if Units.Table (U).Elaborate_Body then 1306 Write_Line 1307 (" (not chosen because of Elaborate_Body)"); 1308 else 1309 Write_Line (" ****************** why not chosen?"); 1310 end if; 1311 end if; 1312 1313 -- Search links list to find unchosen predecessors 1314 1315 for S in Succ.First .. Succ.Last loop 1316 declare 1317 SL : Successor_Link renames Succ.Table (S); 1318 1319 begin 1320 if SL.After = U 1321 and then UNR.Table (SL.Before).Elab_Position = 0 1322 then 1323 Write_Str (" unchosen predecessor: #"); 1324 Write_Int (Int (SL.Before)); 1325 Write_Str (" "); 1326 Write_Unit_Name (Units.Table (SL.Before).Uname); 1327 Write_Eol; 1328 NP := NP - 1; 1329 end if; 1330 end; 1331 end loop; 1332 1333 if NP /= 0 then 1334 Write_Line (" **************** Num_Pred value wrong!"); 1335 end if; 1336 end if; 1337 end loop; 1338 end; 1339 end if; 1340 1341 -- Output the header for the error, and manually increment the error 1342 -- count. We are using Error_Msg_Output rather than Error_Msg here for 1343 -- two reasons: 1344 1345 -- This is really only one error, not one for each line 1346 -- We want this output on standard output since it is voluminous 1347 1348 -- But we do need to deal with the error count manually in this case 1349 1350 Errors_Detected := Errors_Detected + 1; 1351 Error_Msg_Output ("elaboration circularity detected", Info => False); 1352 1353 -- Try to find cycles starting with any of the remaining nodes that have 1354 -- not yet been chosen. There must be at least one (there is some reason 1355 -- we are being called). 1356 1357 for U in Units.First .. Units.Last loop 1358 if UNR.Table (U).Elab_Position = 0 then 1359 if Find_Path (U, U, 1) then 1360 raise Unrecoverable_Error; 1361 end if; 1362 end if; 1363 end loop; 1364 1365 -- We should never get here, since we were called for some reason, and 1366 -- we should have found and eliminated at least one bad path. 1367 1368 raise Program_Error; 1369 end Diagnose_Elaboration_Problem; 1370 1371 -------------------- 1372 -- Elab_All_Links -- 1373 -------------------- 1374 1375 procedure Elab_All_Links 1376 (Before : Unit_Id; 1377 After : Unit_Id; 1378 Reason : Succ_Reason; 1379 Link : Elab_All_Id) 1380 is 1381 begin 1382 if UNR.Table (Before).Visited then 1383 return; 1384 end if; 1385 1386 -- Build the direct link for Before 1387 1388 UNR.Table (Before).Visited := True; 1389 Build_Link (Before, After, Reason, Link); 1390 1391 -- Process all units with'ed by Before recursively 1392 1393 for W in Units.Table (Before).First_With .. 1394 Units.Table (Before).Last_With 1395 loop 1396 -- Skip if this with is an interface to a stand-alone library. Skip 1397 -- also if no ALI file for this WITH, happens for language defined 1398 -- generics while bootstrapping the compiler (see body of routine 1399 -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited with 1400 -- clause, which does not impose an elaboration link. 1401 1402 if not Withs.Table (W).SAL_Interface 1403 and then Withs.Table (W).Afile /= No_File 1404 and then not Withs.Table (W).Limited_With 1405 then 1406 declare 1407 Info : constant Int := 1408 Get_Name_Table_Int (Withs.Table (W).Uname); 1409 1410 begin 1411 -- If the unit is unknown, for some unknown reason, fail 1412 -- graciously explaining that the unit is unknown. Without 1413 -- this check, gnatbind will crash in Unit_Id_Of. 1414 1415 if Info = 0 or else Unit_Id (Info) = No_Unit_Id then 1416 declare 1417 Withed : String := 1418 Get_Name_String (Withs.Table (W).Uname); 1419 Last_Withed : Natural := Withed'Last; 1420 Withing : String := 1421 Get_Name_String 1422 (Units.Table (Before).Uname); 1423 Last_Withing : Natural := Withing'Last; 1424 Spec_Body : String := " (Spec)"; 1425 1426 begin 1427 To_Mixed (Withed); 1428 To_Mixed (Withing); 1429 1430 if Last_Withed > 2 1431 and then Withed (Last_Withed - 1) = '%' 1432 then 1433 Last_Withed := Last_Withed - 2; 1434 end if; 1435 1436 if Last_Withing > 2 1437 and then Withing (Last_Withing - 1) = '%' 1438 then 1439 Last_Withing := Last_Withing - 2; 1440 end if; 1441 1442 if Units.Table (Before).Utype = Is_Body 1443 or else Units.Table (Before).Utype = Is_Body_Only 1444 then 1445 Spec_Body := " (Body)"; 1446 end if; 1447 1448 Osint.Fail 1449 ("could not find unit " 1450 & Withed (Withed'First .. Last_Withed) & " needed by " 1451 & Withing (Withing'First .. Last_Withing) & Spec_Body); 1452 end; 1453 end if; 1454 1455 Elab_All_Links 1456 (Unit_Id_Of (Withs.Table (W).Uname), 1457 After, 1458 Reason, 1459 Make_Elab_All_Entry (Withs.Table (W).Uname, Link)); 1460 end; 1461 end if; 1462 end loop; 1463 1464 -- Process corresponding body, if there is one 1465 1466 if Units.Table (Before).Utype = Is_Spec then 1467 Elab_All_Links 1468 (Corresponding_Body (Before), 1469 After, Reason, 1470 Make_Elab_All_Entry 1471 (Units.Table (Corresponding_Body (Before)).Uname, Link)); 1472 end if; 1473 end Elab_All_Links; 1474 1475 -------------------- 1476 -- Elab_Error_Msg -- 1477 -------------------- 1478 1479 procedure Elab_Error_Msg (S : Successor_Id) is 1480 SL : Successor_Link renames Succ.Table (S); 1481 1482 begin 1483 -- Nothing to do if internal unit involved and no -da flag 1484 1485 if not Debug_Flag_A 1486 and then 1487 (Is_Internal_File_Name (Units.Table (SL.Before).Sfile) 1488 or else 1489 Is_Internal_File_Name (Units.Table (SL.After).Sfile)) 1490 then 1491 return; 1492 end if; 1493 1494 -- Here we want to generate output 1495 1496 Error_Msg_Unit_1 := Units.Table (SL.Before).Uname; 1497 1498 if SL.Elab_Body then 1499 Error_Msg_Unit_2 := Units.Table (Corresponding_Body (SL.After)).Uname; 1500 else 1501 Error_Msg_Unit_2 := Units.Table (SL.After).Uname; 1502 end if; 1503 1504 Error_Msg_Output (" $ must be elaborated before $", Info => True); 1505 1506 Error_Msg_Unit_1 := Units.Table (SL.Reason_Unit).Uname; 1507 1508 case SL.Reason is 1509 when Withed => 1510 Error_Msg_Output 1511 (" reason: with clause", 1512 Info => True); 1513 1514 when Forced => 1515 Error_Msg_Output 1516 (" reason: forced by -f switch", 1517 Info => True); 1518 1519 when Elab => 1520 Error_Msg_Output 1521 (" reason: pragma Elaborate in unit $", 1522 Info => True); 1523 1524 when Elab_All => 1525 Error_Msg_Output 1526 (" reason: pragma Elaborate_All in unit $", 1527 Info => True); 1528 1529 when Elab_All_Desirable => 1530 Error_Msg_Output 1531 (" reason: implicit Elaborate_All in unit $", 1532 Info => True); 1533 1534 Error_Msg_Output 1535 (" recompile $ with -gnatel for full details", 1536 Info => True); 1537 1538 when Elab_Desirable => 1539 Error_Msg_Output 1540 (" reason: implicit Elaborate in unit $", 1541 Info => True); 1542 1543 Error_Msg_Output 1544 (" recompile $ with -gnatel for full details", 1545 Info => True); 1546 1547 when Spec_First => 1548 Error_Msg_Output 1549 (" reason: spec always elaborated before body", 1550 Info => True); 1551 end case; 1552 1553 Write_Elab_All_Chain (S); 1554 1555 if SL.Elab_Body then 1556 Error_Msg_Unit_1 := Units.Table (SL.Before).Uname; 1557 Error_Msg_Unit_2 := Units.Table (SL.After).Uname; 1558 Error_Msg_Output 1559 (" $ must therefore be elaborated before $", True); 1560 1561 Error_Msg_Unit_1 := Units.Table (SL.After).Uname; 1562 Error_Msg_Output 1563 (" (because $ has a pragma Elaborate_Body)", True); 1564 end if; 1565 1566 if not Zero_Formatting then 1567 Write_Eol; 1568 end if; 1569 end Elab_Error_Msg; 1570 1571 --------------------- 1572 -- Find_Elab_Order -- 1573 --------------------- 1574 1575 procedure Find_Elab_Order 1576 (Elab_Order : out Unit_Id_Table; 1577 First_Main_Lib_File : File_Name_Type) 1578 is 1579 function Num_Spec_Body_Pairs (Order : Unit_Id_Array) return Nat; 1580 -- Number of cases where the body of a unit immediately follows the 1581 -- corresponding spec. Such cases are good, because calls to that unit 1582 -- from outside can't get ABE. 1583 1584 ------------------------- 1585 -- Num_Spec_Body_Pairs -- 1586 ------------------------- 1587 1588 function Num_Spec_Body_Pairs (Order : Unit_Id_Array) return Nat is 1589 Result : Nat := 0; 1590 1591 begin 1592 for J in Order'First + 1 .. Order'Last loop 1593 if Units.Table (Order (J - 1)).Utype = Is_Spec 1594 and then Units.Table (Order (J)).Utype = Is_Body 1595 and then Corresponding_Spec (Order (J)) = Order (J - 1) 1596 then 1597 Result := Result + 1; 1598 end if; 1599 end loop; 1600 1601 return Result; 1602 end Num_Spec_Body_Pairs; 1603 1604 -- Local variables 1605 1606 Old_Elab_Order : Unit_Id_Table; 1607 1608 -- Start of processing for Find_Elab_Order 1609 1610 begin 1611 -- Output warning if -p used with no -gnatE units 1612 1613 if Pessimistic_Elab_Order 1614 and not Dynamic_Elaboration_Checks_Specified 1615 then 1616 Error_Msg ("?use of -p switch questionable"); 1617 Error_Msg ("?since all units compiled with static elaboration model"); 1618 end if; 1619 1620 if Do_New and not Debug_Flag_Old and not Debug_Flag_Older then 1621 if Debug_Flag_V then 1622 Write_Line ("Doing new..."); 1623 end if; 1624 1625 Doing_New := True; 1626 Init; 1627 Elab_New.Find_Elab_Order (Elab_Order); 1628 end if; 1629 1630 -- Elab_New does not support the pessimistic order, so if that was 1631 -- requested, use the old results. Use Elab_Old if -dp or -do was 1632 -- selected. Elab_New does not yet give proper error messages for 1633 -- illegal Elaborate_Alls, so if there is one, run Elab_Old. 1634 1635 if Do_Old 1636 or Pessimistic_Elab_Order 1637 or Debug_Flag_Old 1638 or Debug_Flag_Older 1639 or Elab_Cycle_Found 1640 then 1641 if Debug_Flag_V then 1642 Write_Line ("Doing old..."); 1643 end if; 1644 1645 Doing_New := False; 1646 Init; 1647 Elab_Old.Find_Elab_Order (Old_Elab_Order); 1648 end if; 1649 1650 pragma Assert (Elab_Cycle_Found <= -- implies 1651 Diagnose_Elaboration_Problem_Called); 1652 1653 declare 1654 Old_Order : Unit_Id_Array renames 1655 Old_Elab_Order.Table (1 .. Last (Old_Elab_Order)); 1656 begin 1657 if Do_Old and Do_New then 1658 declare 1659 New_Order : Unit_Id_Array renames 1660 Elab_Order.Table (1 .. Last (Elab_Order)); 1661 Old_Pairs : constant Nat := Num_Spec_Body_Pairs (Old_Order); 1662 New_Pairs : constant Nat := Num_Spec_Body_Pairs (New_Order); 1663 1664 begin 1665 Write_Line (Get_Name_String (First_Main_Lib_File)); 1666 1667 pragma Assert (Old_Order'Length = New_Order'Length); 1668 pragma Debug (Validate (Old_Order, Doing_New => False)); 1669 pragma Debug (Validate (New_Order, Doing_New => True)); 1670 1671 -- Misc debug printouts that can be used for experimentation by 1672 -- changing the 'if's below. 1673 1674 if True then 1675 if New_Order = Old_Order then 1676 Write_Line ("Elab_New: same order."); 1677 else 1678 Write_Line ("Elab_New: diff order."); 1679 end if; 1680 end if; 1681 1682 if New_Order /= Old_Order and then False then 1683 Write_Line ("Elaboration orders differ:"); 1684 Write_Elab_Order 1685 (Old_Order, Title => "OLD ELABORATION ORDER"); 1686 Write_Elab_Order 1687 (New_Order, Title => "NEW ELABORATION ORDER"); 1688 end if; 1689 1690 if True then 1691 Write_Str ("Pairs: "); 1692 Write_Int (Old_Pairs); 1693 1694 if Old_Pairs = New_Pairs then 1695 Write_Str (" = "); 1696 elsif Old_Pairs < New_Pairs then 1697 Write_Str (" < "); 1698 else 1699 Write_Str (" > "); 1700 end if; 1701 1702 Write_Int (New_Pairs); 1703 Write_Eol; 1704 end if; 1705 1706 if Old_Pairs /= New_Pairs and then False then 1707 Write_Str ("Pairs: "); 1708 Write_Int (Old_Pairs); 1709 1710 if Old_Pairs < New_Pairs then 1711 Write_Str (" < "); 1712 else 1713 Write_Str (" > "); 1714 end if; 1715 1716 Write_Int (New_Pairs); 1717 Write_Eol; 1718 1719 if Old_Pairs /= New_Pairs and then Debug_Flag_V then 1720 Write_Elab_Order 1721 (Old_Order, Title => "OLD ELABORATION ORDER"); 1722 Write_Elab_Order 1723 (New_Order, Title => "NEW ELABORATION ORDER"); 1724 pragma Assert (New_Pairs >= Old_Pairs); 1725 end if; 1726 end if; 1727 end; 1728 end if; 1729 1730 -- The Elab_New algorithm doesn't implement the -p switch, so if that 1731 -- was used, use the results from the old algorithm. Likewise if the 1732 -- user has requested the old algorithm. 1733 1734 if Pessimistic_Elab_Order or Debug_Flag_Old or Debug_Flag_Older then 1735 pragma Assert 1736 (Last (Elab_Order) = 0 1737 or else Last (Elab_Order) = Old_Order'Last); 1738 1739 Init (Elab_Order); 1740 Append_All (Elab_Order, Old_Order); 1741 end if; 1742 1743 -- Now set the Elab_Positions in the Units table. It is important to 1744 -- do this late, in case we're running both Elab_New and Elab_Old. 1745 1746 declare 1747 New_Order : Unit_Id_Array renames 1748 Elab_Order.Table (1 .. Last (Elab_Order)); 1749 Units_Array : Units.Table_Type renames 1750 Units.Table (Units.First .. Units.Last); 1751 begin 1752 for J in New_Order'Range loop 1753 pragma Assert 1754 (UNR.Table (New_Order (J)).Elab_Position = J); 1755 Units_Array (New_Order (J)).Elab_Position := J; 1756 end loop; 1757 1758 if Errors_Detected = 0 then 1759 1760 -- Display elaboration order if -l was specified 1761 1762 if Elab_Order_Output then 1763 if Zero_Formatting then 1764 Write_Elab_Order (New_Order, Title => ""); 1765 else 1766 Write_Elab_Order 1767 (New_Order, Title => "ELABORATION ORDER"); 1768 end if; 1769 end if; 1770 1771 -- Display list of sources in the closure (except predefined 1772 -- sources) if -R was used. Include predefined sources if -Ra 1773 -- was used. 1774 1775 if List_Closure then 1776 Write_Closure (New_Order); 1777 end if; 1778 end if; 1779 end; 1780 end; 1781 end Find_Elab_Order; 1782 1783 ---------------------- 1784 -- Force_Elab_Order -- 1785 ---------------------- 1786 1787 procedure Force_Elab_Order is 1788 use System.OS_Lib; 1789 -- There is a lot of fiddly string manipulation below, because we don't 1790 -- want to depend on misc utility packages like Ada.Characters.Handling. 1791 1792 function Get_Line return String; 1793 -- Read the next line from the file content read by Read_File. Strip 1794 -- all leading and trailing blanks. Convert "(spec)" or "(body)" to 1795 -- "%s"/"%b". Remove comments (Ada style; "--" to end of line). 1796 1797 function Read_File (Name : String) return String_Ptr; 1798 -- Read the entire contents of the named file 1799 1800 subtype Header_Num is Unit_Name_Type'Base range 0 .. 2**16 - 1; 1801 type Line_Number is new Nat; 1802 No_Line_Number : constant Line_Number := 0; 1803 Cur_Line_Number : Line_Number := 0; 1804 -- Current line number in the Force_Elab_Order_File. 1805 -- Incremented by Get_Line. Used in error messages. 1806 1807 function Hash (N : Unit_Name_Type) return Header_Num; 1808 1809 package Name_Map is new System.HTable.Simple_HTable 1810 (Header_Num => Header_Num, 1811 Element => Line_Number, 1812 No_Element => No_Line_Number, 1813 Key => Unit_Name_Type, 1814 Hash => Hash, 1815 Equal => "="); 1816 -- Name_Map contains an entry for each file name seen, mapped to the 1817 -- line number where we saw it first. This is used to give an error for 1818 -- duplicates. 1819 1820 ---------- 1821 -- Hash -- 1822 ---------- 1823 1824 function Hash (N : Unit_Name_Type) return Header_Num is 1825 -- Name_Ids are already widely dispersed; no need for any actual 1826 -- hashing. Just subtract to make it zero based, and "mod" to 1827 -- bring it in range. 1828 begin 1829 return (N - Unit_Name_Type'First) mod (Header_Num'Last + 1); 1830 end Hash; 1831 1832 --------------- 1833 -- Read_File -- 1834 --------------- 1835 1836 function Read_File (Name : String) return String_Ptr is 1837 1838 -- All of the following calls should succeed, because we checked the 1839 -- file in Switch.B, but we double check and raise Program_Error on 1840 -- failure, just in case. 1841 1842 F : constant File_Descriptor := Open_Read (Name, Binary); 1843 1844 begin 1845 if F = Invalid_FD then 1846 raise Program_Error; 1847 end if; 1848 1849 declare 1850 Len : constant Natural := Natural (File_Length (F)); 1851 Result : constant String_Ptr := new String (1 .. Len); 1852 Len_Read : constant Natural := 1853 Read (F, Result (1)'Address, Len); 1854 1855 Status : Boolean; 1856 1857 begin 1858 if Len_Read /= Len then 1859 raise Program_Error; 1860 end if; 1861 1862 Close (F, Status); 1863 1864 if not Status then 1865 raise Program_Error; 1866 end if; 1867 1868 return Result; 1869 end; 1870 end Read_File; 1871 1872 Cur : Positive := 1; 1873 S : String_Ptr := Read_File (Force_Elab_Order_File.all); 1874 1875 -------------- 1876 -- Get_Line -- 1877 -------------- 1878 1879 function Get_Line return String is 1880 First : Positive := Cur; 1881 Last : Natural; 1882 1883 begin 1884 Cur_Line_Number := Cur_Line_Number + 1; 1885 1886 -- Skip to end of line 1887 1888 while Cur <= S'Last 1889 and then S (Cur) /= ASCII.LF 1890 and then S (Cur) /= ASCII.CR 1891 loop 1892 Cur := Cur + 1; 1893 end loop; 1894 1895 -- Strip leading blanks 1896 1897 while First <= S'Last and then S (First) = ' ' loop 1898 First := First + 1; 1899 end loop; 1900 1901 -- Strip trailing blanks and comment 1902 1903 Last := Cur - 1; 1904 1905 for J in First .. Last - 1 loop 1906 if S (J .. J + 1) = "--" then 1907 Last := J - 1; 1908 exit; 1909 end if; 1910 end loop; 1911 1912 while Last >= First and then S (Last) = ' ' loop 1913 Last := Last - 1; 1914 end loop; 1915 1916 -- Convert "(spec)" or "(body)" to "%s"/"%b", strip trailing blanks 1917 -- again. 1918 1919 declare 1920 Body_String : constant String := "(body)"; 1921 BL : constant Positive := Body_String'Length; 1922 Spec_String : constant String := "(spec)"; 1923 SL : constant Positive := Spec_String'Length; 1924 1925 Line : String renames S (First .. Last); 1926 1927 Is_Body : Boolean := False; 1928 Is_Spec : Boolean := False; 1929 1930 begin 1931 if Line'Length >= SL 1932 and then Line (Last - SL + 1 .. Last) = Spec_String 1933 then 1934 Is_Spec := True; 1935 Last := Last - SL; 1936 elsif Line'Length >= BL 1937 and then Line (Last - BL + 1 .. Last) = Body_String 1938 then 1939 Is_Body := True; 1940 Last := Last - BL; 1941 end if; 1942 1943 while Last >= First and then S (Last) = ' ' loop 1944 Last := Last - 1; 1945 end loop; 1946 1947 -- Skip past LF or CR/LF 1948 1949 if Cur <= S'Last and then S (Cur) = ASCII.CR then 1950 Cur := Cur + 1; 1951 end if; 1952 1953 if Cur <= S'Last and then S (Cur) = ASCII.LF then 1954 Cur := Cur + 1; 1955 end if; 1956 1957 if Is_Spec then 1958 return Line (First .. Last) & "%s"; 1959 elsif Is_Body then 1960 return Line (First .. Last) & "%b"; 1961 else 1962 return Line; 1963 end if; 1964 end; 1965 end Get_Line; 1966 1967 -- Local variables 1968 1969 Empty_Name : constant Unit_Name_Type := Name_Find (""); 1970 Prev_Unit : Unit_Id := No_Unit_Id; 1971 1972 -- Start of processing for Force_Elab_Order 1973 1974 begin 1975 -- Loop through the file content, and build a dependency link for each 1976 -- pair of lines. Ignore lines that should be ignored. 1977 1978 while Cur <= S'Last loop 1979 declare 1980 Uname : constant Unit_Name_Type := Name_Find (Get_Line); 1981 Error : Boolean := False; 1982 1983 begin 1984 if Uname = Empty_Name then 1985 null; -- silently skip blank lines 1986 else 1987 declare 1988 Dup : constant Line_Number := Name_Map.Get (Uname); 1989 begin 1990 if Dup = No_Line_Number then 1991 Name_Map.Set (Uname, Cur_Line_Number); 1992 1993 -- We don't need to give the "not present" message in 1994 -- the case of "duplicate unit", because we would have 1995 -- already given the "not present" message on the 1996 -- first occurrence. 1997 1998 if Get_Name_Table_Int (Uname) = 0 1999 or else Unit_Id (Get_Name_Table_Int (Uname)) = 2000 No_Unit_Id 2001 then 2002 Error := True; 2003 if Doing_New then 2004 Write_Line 2005 ("""" & Get_Name_String (Uname) 2006 & """: not present; ignored"); 2007 end if; 2008 end if; 2009 2010 else 2011 Error := True; 2012 if Doing_New then 2013 Error_Msg_Nat_1 := Nat (Cur_Line_Number); 2014 Error_Msg_Unit_1 := Uname; 2015 Error_Msg_Nat_2 := Nat (Dup); 2016 Error_Msg 2017 (Force_Elab_Order_File.all 2018 & ":#: duplicate unit name $ from line #"); 2019 end if; 2020 end if; 2021 end; 2022 2023 if not Error then 2024 declare 2025 Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname); 2026 begin 2027 if Is_Internal_File_Name 2028 (Units.Table (Cur_Unit).Sfile) 2029 then 2030 if Doing_New then 2031 Write_Line 2032 ("""" & Get_Name_String (Uname) 2033 & """: predefined unit ignored"); 2034 end if; 2035 2036 else 2037 if Prev_Unit /= No_Unit_Id then 2038 if Doing_New then 2039 Write_Unit_Name (Units.Table (Prev_Unit).Uname); 2040 Write_Str (" <-- "); 2041 Write_Unit_Name (Units.Table (Cur_Unit).Uname); 2042 Write_Eol; 2043 end if; 2044 2045 Build_Link 2046 (Before => Prev_Unit, 2047 After => Cur_Unit, 2048 R => Forced); 2049 end if; 2050 2051 Prev_Unit := Cur_Unit; 2052 end if; 2053 end; 2054 end if; 2055 end if; 2056 end; 2057 end loop; 2058 2059 Free (S); 2060 end Force_Elab_Order; 2061 2062 ------------------------- 2063 -- Gather_Dependencies -- 2064 ------------------------- 2065 2066 procedure Gather_Dependencies is 2067 Withed_Unit : Unit_Id; 2068 2069 begin 2070 -- Loop through all units 2071 2072 for U in Units.First .. Units.Last loop 2073 Cur_Unit := U; 2074 2075 -- If this is not an interface to a stand-alone library and there is 2076 -- a body and a spec, then spec must be elaborated first. Note that 2077 -- the corresponding spec immediately follows the body. 2078 2079 if not Units.Table (U).SAL_Interface 2080 and then Units.Table (U).Utype = Is_Body 2081 then 2082 Build_Link (Corresponding_Spec (U), U, Spec_First); 2083 end if; 2084 2085 -- If this unit is not an interface to a stand-alone library, process 2086 -- WITH references for this unit ignoring interfaces to stand-alone 2087 -- libraries. 2088 2089 if not Units.Table (U).SAL_Interface then 2090 for W in Units.Table (U).First_With .. 2091 Units.Table (U).Last_With 2092 loop 2093 if Withs.Table (W).Sfile /= No_File 2094 and then (not Withs.Table (W).SAL_Interface) 2095 then 2096 -- Check for special case of withing a unit that does not 2097 -- exist any more. If the unit was completely missing we 2098 -- would already have detected this, but a nasty case arises 2099 -- when we have a subprogram body with no spec, and some 2100 -- obsolete unit with's a previous (now disappeared) spec. 2101 2102 if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then 2103 if Doing_New then 2104 Error_Msg_File_1 := Units.Table (U).Sfile; 2105 Error_Msg_Unit_1 := Withs.Table (W).Uname; 2106 Error_Msg ("{ depends on $ which no longer exists"); 2107 end if; 2108 2109 goto Next_With; 2110 end if; 2111 2112 Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname); 2113 2114 -- Pragma Elaborate_All case, for this we use the recursive 2115 -- Elab_All_Links procedure to establish the links. 2116 2117 -- Elab_New ignores Elaborate_All and Elab_All_Desirable, 2118 -- except for error messages. 2119 2120 if Withs.Table (W).Elaborate_All and then not Doing_New then 2121 2122 -- Reset flags used to stop multiple visits to a given 2123 -- node. 2124 2125 for Uref in UNR.First .. UNR.Last loop 2126 UNR.Table (Uref).Visited := False; 2127 end loop; 2128 2129 -- Now establish all the links we need 2130 2131 Elab_All_Links 2132 (Withed_Unit, U, Elab_All, 2133 Make_Elab_All_Entry 2134 (Withs.Table (W).Uname, No_Elab_All_Link)); 2135 2136 -- Elaborate_All_Desirable case, for this we establish the 2137 -- same links as above, but with a different reason. 2138 2139 elsif Withs.Table (W).Elab_All_Desirable 2140 and then not Doing_New 2141 then 2142 -- Reset flags used to stop multiple visits to a given 2143 -- node. 2144 2145 for Uref in UNR.First .. UNR.Last loop 2146 UNR.Table (Uref).Visited := False; 2147 end loop; 2148 2149 -- Now establish all the links we need 2150 2151 Elab_All_Links 2152 (Withed_Unit, U, Elab_All_Desirable, 2153 Make_Elab_All_Entry 2154 (Withs.Table (W).Uname, No_Elab_All_Link)); 2155 2156 -- Pragma Elaborate case. We must build a link for the 2157 -- withed unit itself, and also the corresponding body if 2158 -- there is one. 2159 2160 -- However, skip this processing if there is no ALI file for 2161 -- the WITH entry, because this means it is a generic (even 2162 -- when we fix the generics so that an ALI file is present, 2163 -- we probably still will have no ALI file for unchecked and 2164 -- other special cases). 2165 2166 elsif Withs.Table (W).Elaborate 2167 and then Withs.Table (W).Afile /= No_File 2168 then 2169 Build_Link (Withed_Unit, U, Withed); 2170 2171 if Units.Table (Withed_Unit).Utype = Is_Spec then 2172 Build_Link 2173 (Corresponding_Body (Withed_Unit), U, Elab); 2174 end if; 2175 2176 -- Elaborate_Desirable case, for this we establish the same 2177 -- links as above, but with a different reason. 2178 2179 elsif Withs.Table (W).Elab_Desirable then 2180 Build_Link (Withed_Unit, U, Withed); 2181 2182 if Units.Table (Withed_Unit).Utype = Is_Spec then 2183 Build_Link 2184 (Corresponding_Body (Withed_Unit), 2185 U, Elab_Desirable); 2186 end if; 2187 2188 -- A limited_with does not establish an elaboration 2189 -- dependence (that's the whole point). 2190 2191 elsif Withs.Table (W).Limited_With then 2192 null; 2193 2194 -- Case of normal WITH with no elaboration pragmas, just 2195 -- build the single link to the directly referenced unit 2196 2197 else 2198 Build_Link (Withed_Unit, U, Withed); 2199 end if; 2200 end if; 2201 2202 <<Next_With>> 2203 null; 2204 end loop; 2205 end if; 2206 end loop; 2207 2208 -- If -f<elab_order> switch was given, take into account dependences 2209 -- specified in the file <elab_order>. 2210 2211 if Force_Elab_Order_File /= null then 2212 Force_Elab_Order; 2213 end if; 2214 2215 -- Output elaboration dependencies if option is set 2216 2217 if Elab_Dependency_Output or Debug_Flag_E then 2218 if Doing_New then 2219 Write_Dependencies; 2220 end if; 2221 end if; 2222 end Gather_Dependencies; 2223 2224 ---------- 2225 -- Init -- 2226 ---------- 2227 2228 procedure Init is 2229 begin 2230 Num_Chosen := 0; 2231 Num_Left := Int (Units.Last - Units.First + 1); 2232 Succ.Init; 2233 Elab_All_Entries.Init; 2234 UNR.Init; 2235 2236 -- Initialize unit table for elaboration control 2237 2238 for U in Units.First .. Units.Last loop 2239 UNR.Append 2240 ((Successors => No_Successor, 2241 Num_Pred => 0, 2242 Nextnp => No_Unit_Id, 2243 Visited => False, 2244 Elab_Position => 0, 2245 SCC_Root => No_Unit_Id, 2246 Nodes => null, 2247 SCC_Num_Pred => 0, 2248 Validate_Seen => False)); 2249 end loop; 2250 end Init; 2251 2252 ------------------ 2253 -- Is_Body_Unit -- 2254 ------------------ 2255 2256 function Is_Body_Unit (U : Unit_Id) return Boolean is 2257 begin 2258 return 2259 Units.Table (U).Utype = Is_Body 2260 or else Units.Table (U).Utype = Is_Body_Only; 2261 end Is_Body_Unit; 2262 2263 ----------------------------- 2264 -- Is_Pure_Or_Preelab_Unit -- 2265 ----------------------------- 2266 2267 function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean is 2268 begin 2269 -- If we have a body with separate spec, test flags on the spec 2270 2271 if Units.Table (U).Utype = Is_Body then 2272 return 2273 Units.Table (Corresponding_Spec (U)).Preelab 2274 or else Units.Table (Corresponding_Spec (U)).Pure; 2275 2276 -- Otherwise we have a spec or body acting as spec, test flags on unit 2277 2278 else 2279 return Units.Table (U).Preelab or else Units.Table (U).Pure; 2280 end if; 2281 end Is_Pure_Or_Preelab_Unit; 2282 2283 --------------------- 2284 -- Is_Waiting_Body -- 2285 --------------------- 2286 2287 function Is_Waiting_Body (U : Unit_Id) return Boolean is 2288 begin 2289 return 2290 Units.Table (U).Utype = Is_Body 2291 and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0; 2292 end Is_Waiting_Body; 2293 2294 ------------------------- 2295 -- Make_Elab_All_Entry -- 2296 ------------------------- 2297 2298 function Make_Elab_All_Entry 2299 (Unam : Unit_Name_Type; 2300 Link : Elab_All_Id) return Elab_All_Id 2301 is 2302 begin 2303 Elab_All_Entries.Append ((Needed_By => Unam, Next_Elab => Link)); 2304 return Elab_All_Entries.Last; 2305 end Make_Elab_All_Entry; 2306 2307 ---------------- 2308 -- Unit_Id_Of -- 2309 ---------------- 2310 2311 function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is 2312 Info : constant Int := Get_Name_Table_Int (Uname); 2313 2314 begin 2315 pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); 2316 return Unit_Id (Info); 2317 end Unit_Id_Of; 2318 2319 -------------- 2320 -- Validate -- 2321 -------------- 2322 2323 procedure Validate (Order : Unit_Id_Array; Doing_New : Boolean) is 2324 Cur_SCC : Unit_Id := No_Unit_Id; 2325 OK : Boolean := True; 2326 Msg : String := "Old: "; 2327 2328 begin 2329 if Doing_New then 2330 Msg := "New: "; 2331 end if; 2332 2333 -- For each unit, assert that its successors are elaborated after it 2334 2335 for J in Order'Range loop 2336 declare 2337 U : constant Unit_Id := Order (J); 2338 S : Successor_Id := UNR.Table (U).Successors; 2339 2340 begin 2341 while S /= No_Successor loop 2342 if UNR.Table (Succ.Table (S).After).Elab_Position <= 2343 UNR.Table (U).Elab_Position 2344 then 2345 OK := False; 2346 Write_Line (Msg & " elab order failed"); 2347 end if; 2348 2349 S := Succ.Table (S).Next; 2350 end loop; 2351 end; 2352 end loop; 2353 2354 -- An SCC of size 2 units necessarily consists of a spec and the 2355 -- corresponding body. Assert that the body is elaborated immediately 2356 -- after the spec, with nothing in between. (We only have SCCs in the 2357 -- new algorithm.) 2358 2359 if Doing_New then 2360 for J in Order'Range loop 2361 declare 2362 U : constant Unit_Id := Order (J); 2363 2364 begin 2365 if Nodes (U)'Length = 2 then 2366 if Units.Table (U).Utype = Is_Spec then 2367 if Order (J + 1) /= Corresponding_Body (U) then 2368 OK := False; 2369 Write_Line (Msg & "Bad spec with SCC of size 2:"); 2370 Write_SCC (SCC (U)); 2371 end if; 2372 end if; 2373 2374 if Units.Table (U).Utype = Is_Body then 2375 if Order (J - 1) /= Corresponding_Spec (U) then 2376 OK := False; 2377 Write_Line (Msg & "Bad body with SCC of size 2:"); 2378 Write_SCC (SCC (U)); 2379 end if; 2380 end if; 2381 end if; 2382 end; 2383 end loop; 2384 2385 -- Assert that all units of an SCC are elaborated together, with no 2386 -- units from other SCCs in between. The above spec/body case is a 2387 -- special case of this general rule. 2388 2389 for J in Order'Range loop 2390 declare 2391 U : constant Unit_Id := Order (J); 2392 2393 begin 2394 if SCC (U) /= Cur_SCC then 2395 Cur_SCC := SCC (U); 2396 if UNR.Table (Cur_SCC).Validate_Seen then 2397 OK := False; 2398 Write_Line (Msg & "SCC not elaborated together:"); 2399 Write_SCC (Cur_SCC); 2400 end if; 2401 2402 UNR.Table (Cur_SCC).Validate_Seen := True; 2403 end if; 2404 end; 2405 end loop; 2406 end if; 2407 2408 pragma Assert (OK); 2409 end Validate; 2410 2411 ------------------- 2412 -- Write_Closure -- 2413 ------------------- 2414 2415 procedure Write_Closure (Order : Unit_Id_Array) is 2416 package Closure_Sources is new Table.Table 2417 (Table_Component_Type => File_Name_Type, 2418 Table_Index_Type => Natural, 2419 Table_Low_Bound => 1, 2420 Table_Initial => 10, 2421 Table_Increment => 100, 2422 Table_Name => "Gnatbind.Closure_Sources"); 2423 -- Table to record the sources in the closure, to avoid duplications 2424 2425 function Put_In_Sources (S : File_Name_Type) return Boolean; 2426 -- Check if S is already in table Sources and put in Sources if it is 2427 -- not. Return False if the source is already in Sources, and True if 2428 -- it is added. 2429 2430 -------------------- 2431 -- Put_In_Sources -- 2432 -------------------- 2433 2434 function Put_In_Sources (S : File_Name_Type) return Boolean is 2435 begin 2436 for J in 1 .. Closure_Sources.Last loop 2437 if Closure_Sources.Table (J) = S then 2438 return False; 2439 end if; 2440 end loop; 2441 2442 Closure_Sources.Append (S); 2443 return True; 2444 end Put_In_Sources; 2445 2446 -- Local variables 2447 2448 Source : File_Name_Type; 2449 2450 -- Start of processing for Write_Closure 2451 2452 begin 2453 Closure_Sources.Init; 2454 2455 if not Zero_Formatting then 2456 Write_Eol; 2457 Write_Line ("REFERENCED SOURCES"); 2458 end if; 2459 2460 for J in reverse Order'Range loop 2461 Source := Units.Table (Order (J)).Sfile; 2462 2463 -- Do not include same source more than once 2464 2465 if Put_In_Sources (Source) 2466 2467 -- Do not include run-time units unless -Ra switch set 2468 2469 and then (List_Closure_All 2470 or else not Is_Internal_File_Name (Source)) 2471 then 2472 if not Zero_Formatting then 2473 Write_Str (" "); 2474 end if; 2475 2476 Write_Line (Get_Name_String (Source)); 2477 end if; 2478 end loop; 2479 2480 -- Subunits do not appear in the elaboration table because they are 2481 -- subsumed by their parent units, but we need to list them for other 2482 -- tools. For now they are listed after other files, rather than right 2483 -- after their parent, since there is no easy link between the 2484 -- elaboration table and the ALIs table ??? As subunits may appear 2485 -- repeatedly in the list, if the parent unit appears in the context of 2486 -- several units in the closure, duplicates are suppressed. 2487 2488 for J in Sdep.First .. Sdep.Last loop 2489 Source := Sdep.Table (J).Sfile; 2490 2491 if Sdep.Table (J).Subunit_Name /= No_Name 2492 and then Put_In_Sources (Source) 2493 and then not Is_Internal_File_Name (Source) 2494 then 2495 if not Zero_Formatting then 2496 Write_Str (" "); 2497 end if; 2498 2499 Write_Line (Get_Name_String (Source)); 2500 end if; 2501 end loop; 2502 2503 if not Zero_Formatting then 2504 Write_Eol; 2505 end if; 2506 end Write_Closure; 2507 2508 ------------------------ 2509 -- Write_Dependencies -- 2510 ------------------------ 2511 2512 procedure Write_Dependencies is 2513 begin 2514 if not Zero_Formatting then 2515 Write_Eol; 2516 Write_Line (" ELABORATION ORDER DEPENDENCIES"); 2517 Write_Eol; 2518 end if; 2519 2520 Info_Prefix_Suppress := True; 2521 2522 for S in Succ_First .. Succ.Last loop 2523 Elab_Error_Msg (S); 2524 end loop; 2525 2526 Info_Prefix_Suppress := False; 2527 2528 if not Zero_Formatting then 2529 Write_Eol; 2530 end if; 2531 end Write_Dependencies; 2532 2533 -------------------------- 2534 -- Write_Elab_All_Chain -- 2535 -------------------------- 2536 2537 procedure Write_Elab_All_Chain (S : Successor_Id) is 2538 ST : constant Successor_Link := Succ.Table (S); 2539 After : constant Unit_Name_Type := Units.Table (ST.After).Uname; 2540 2541 L : Elab_All_Id; 2542 Nam : Unit_Name_Type; 2543 2544 First_Name : Boolean := True; 2545 2546 begin 2547 if ST.Reason in Elab_All .. Elab_All_Desirable then 2548 L := ST.Elab_All_Link; 2549 while L /= No_Elab_All_Link loop 2550 Nam := Elab_All_Entries.Table (L).Needed_By; 2551 Error_Msg_Unit_1 := Nam; 2552 Error_Msg_Output (" $", Info => True); 2553 2554 Get_Name_String (Nam); 2555 2556 if Name_Buffer (Name_Len) = 'b' then 2557 if First_Name then 2558 Error_Msg_Output 2559 (" must be elaborated along with its spec:", 2560 Info => True); 2561 2562 else 2563 Error_Msg_Output 2564 (" which must be elaborated along with its " 2565 & "spec:", 2566 Info => True); 2567 end if; 2568 2569 else 2570 if First_Name then 2571 Error_Msg_Output 2572 (" is withed by:", 2573 Info => True); 2574 2575 else 2576 Error_Msg_Output 2577 (" which is withed by:", 2578 Info => True); 2579 end if; 2580 end if; 2581 2582 First_Name := False; 2583 2584 L := Elab_All_Entries.Table (L).Next_Elab; 2585 end loop; 2586 2587 Error_Msg_Unit_1 := After; 2588 Error_Msg_Output (" $", Info => True); 2589 end if; 2590 end Write_Elab_All_Chain; 2591 2592 ---------------------- 2593 -- Write_Elab_Order -- 2594 ---------------------- 2595 2596 procedure Write_Elab_Order 2597 (Order : Unit_Id_Array; Title : String) 2598 is 2599 begin 2600 if Title /= "" then 2601 Write_Eol; 2602 Write_Line (Title); 2603 end if; 2604 2605 for J in Order'Range loop 2606 if not Units.Table (Order (J)).SAL_Interface then 2607 if not Zero_Formatting then 2608 Write_Str (" "); 2609 end if; 2610 2611 Write_Unit_Name (Units.Table (Order (J)).Uname); 2612 Write_Eol; 2613 end if; 2614 end loop; 2615 2616 if Title /= "" then 2617 Write_Eol; 2618 end if; 2619 end Write_Elab_Order; 2620 2621 -------------- 2622 -- Elab_New -- 2623 -------------- 2624 2625 package body Elab_New is 2626 2627 generic 2628 type Node is (<>); 2629 First_Node : Node; 2630 Last_Node : Node; 2631 type Node_Array is array (Pos range <>) of Node; 2632 with function Successors (N : Node) return Node_Array; 2633 with procedure Create_SCC (Root : Node; Nodes : Node_Array); 2634 2635 procedure Compute_Strongly_Connected_Components; 2636 -- Compute SCCs for a directed graph. The nodes in the graph are all 2637 -- values of type Node in the range First_Node .. Last_Node. 2638 -- Successors(N) returns the nodes pointed to by the edges emanating 2639 -- from N. Create_SCC is a callback that is called once for each SCC, 2640 -- passing in the Root node for that SCC (which is an arbitrary node in 2641 -- the SCC used as a representative of that SCC), and the set of Nodes 2642 -- in that SCC. 2643 -- 2644 -- This is generic, in case we want to use it elsewhere; then we could 2645 -- move this into a separate library unit. Unfortunately, it's not as 2646 -- generic as one might like. Ideally, we would have "type Node is 2647 -- private;", and pass in iterators to iterate over all nodes, and over 2648 -- the successors of a given node. However, that leads to using advanced 2649 -- features of Ada that are not allowed in the compiler and binder for 2650 -- bootstrapping reasons. It also leads to trampolines, which are not 2651 -- allowed in the compiler and binder. Restricting Node to be discrete 2652 -- allows us to iterate over all nodes with a 'for' loop, and allows us 2653 -- to attach temporary information to nodes by having an array indexed 2654 -- by Node. 2655 2656 procedure Compute_Unit_SCCs; 2657 -- Use the above generic procedure to compute the SCCs for the graph of 2658 -- units. Store in each Unit_Node_Record the SCC_Root and Nodes 2659 -- components. Also initialize the SCC_Num_Pred components. 2660 2661 procedure Find_Elab_All_Errors; 2662 -- Generate an error for illegal Elaborate_All pragmas (explicit or 2663 -- implicit). A pragma Elaborate_All (Y) on unit X is legal if and only 2664 -- if X and Y are in different SCCs. 2665 2666 ------------------------------------------- 2667 -- Compute_Strongly_Connected_Components -- 2668 ------------------------------------------- 2669 2670 procedure Compute_Strongly_Connected_Components is 2671 2672 -- This uses Tarjan's algorithm for finding SCCs. Comments here are 2673 -- intended to tell what it does, but if you want to know how it 2674 -- works, you have to look it up. Please do not modify this code 2675 -- without reading up on Tarjan's algorithm. 2676 2677 subtype Node_Index is Nat; 2678 No_Index : constant Node_Index := 0; 2679 2680 Num_Nodes : constant Nat := 2681 Node'Pos (Last_Node) - Node'Pos (First_Node) + 1; 2682 Stack : Node_Array (1 .. Num_Nodes); 2683 Top : Node_Index := 0; 2684 -- Stack of nodes, pushed when first visited. All nodes of an SCC are 2685 -- popped at once when the SCC is found. 2686 2687 subtype Valid_Node is Node range First_Node .. Last_Node; 2688 Node_Indices : array (Valid_Node) of Node_Index := 2689 (others => No_Index); 2690 -- Each node has an "index", which is the sequential number in the 2691 -- order in which they are visited in the recursive walk. No_Index 2692 -- means "not yet visited"; we want to avoid walking any node more 2693 -- than once. 2694 2695 Index : Node_Index := 1; 2696 -- Next value to be assigned to a node index 2697 2698 Low_Links : array (Valid_Node) of Node_Index; 2699 -- Low_Links (N) is the smallest index of nodes reachable from N 2700 2701 On_Stack : array (Valid_Node) of Boolean := (others => False); 2702 -- True if the node is currently on the stack 2703 2704 procedure Walk (N : Valid_Node); 2705 -- Recursive depth-first graph walk, with the node index used to 2706 -- avoid visiting a node more than once. 2707 2708 ---------- 2709 -- Walk -- 2710 ---------- 2711 2712 procedure Walk (N : Valid_Node) is 2713 Stack_Position_Of_N : constant Pos := Top + 1; 2714 S : constant Node_Array := Successors (N); 2715 2716 begin 2717 -- Assign the index and low link, increment Index for next call to 2718 -- Walk. 2719 2720 Node_Indices (N) := Index; 2721 Low_Links (N) := Index; 2722 Index := Index + 1; 2723 2724 -- Push it on the stack: 2725 2726 Top := Stack_Position_Of_N; 2727 Stack (Top) := N; 2728 On_Stack (N) := True; 2729 2730 -- Walk not-yet-visited subnodes, and update low link for visited 2731 -- ones as appropriate. 2732 2733 for J in S'Range loop 2734 if Node_Indices (S (J)) = No_Index then 2735 Walk (S (J)); 2736 Low_Links (N) := 2737 Node_Index'Min (Low_Links (N), Low_Links (S (J))); 2738 elsif On_Stack (S (J)) then 2739 Low_Links (N) := 2740 Node_Index'Min (Low_Links (N), Node_Indices (S (J))); 2741 end if; 2742 end loop; 2743 2744 -- If the index is (still) equal to the low link, we've found an 2745 -- SCC. Pop the whole SCC off the stack, and call Create_SCC. 2746 2747 if Low_Links (N) = Node_Indices (N) then 2748 declare 2749 SCC : Node_Array renames 2750 Stack (Stack_Position_Of_N .. Top); 2751 pragma Assert (SCC'Length >= 1); 2752 pragma Assert (SCC (SCC'First) = N); 2753 2754 begin 2755 for J in SCC'Range loop 2756 On_Stack (SCC (J)) := False; 2757 end loop; 2758 2759 Create_SCC (Root => N, Nodes => SCC); 2760 pragma Assert (Top - SCC'Length = Stack_Position_Of_N - 1); 2761 Top := Stack_Position_Of_N - 1; -- pop all 2762 end; 2763 end if; 2764 end Walk; 2765 2766 -- Start of processing for Compute_Strongly_Connected_Components 2767 2768 begin 2769 -- Walk all the nodes that have not yet been walked 2770 2771 for N in Valid_Node loop 2772 if Node_Indices (N) = No_Index then 2773 Walk (N); 2774 end if; 2775 end loop; 2776 end Compute_Strongly_Connected_Components; 2777 2778 ----------------------- 2779 -- Compute_Unit_SCCs -- 2780 ----------------------- 2781 2782 procedure Compute_Unit_SCCs is 2783 function Successors (U : Unit_Id) return Unit_Id_Array; 2784 -- Return all the units that must be elaborated after U. In addition, 2785 -- if U is a body, include the corresponding spec; this ensures that 2786 -- a spec/body pair are always in the same SCC. 2787 2788 procedure Create_SCC (Root : Unit_Id; Nodes : Unit_Id_Array); 2789 -- Set Nodes of the Root, and set SCC_Root of all the Nodes 2790 2791 procedure Init_SCC_Num_Pred (U : Unit_Id); 2792 -- Initialize the SCC_Num_Pred fields, so that the root of each SCC 2793 -- has a count of the number of successors of all the units in the 2794 -- SCC, but only for successors outside the SCC. 2795 2796 procedure Compute_SCCs is new Compute_Strongly_Connected_Components 2797 (Node => Unit_Id, 2798 First_Node => Units.First, 2799 Last_Node => Units.Last, 2800 Node_Array => Unit_Id_Array, 2801 Successors => Successors, 2802 Create_SCC => Create_SCC); 2803 2804 ---------------- 2805 -- Create_SCC -- 2806 ---------------- 2807 2808 procedure Create_SCC (Root : Unit_Id; Nodes : Unit_Id_Array) is 2809 begin 2810 if Debug_Flag_V then 2811 Write_Str ("Root = "); 2812 Write_Int (Int (Root)); 2813 Write_Str (" "); 2814 Write_Unit_Name (Units.Table (Root).Uname); 2815 Write_Str (" -- "); 2816 Write_Int (Nodes'Length); 2817 Write_Line (" units:"); 2818 2819 for J in Nodes'Range loop 2820 Write_Str (" "); 2821 Write_Int (Int (Nodes (J))); 2822 Write_Str (" "); 2823 Write_Unit_Name (Units.Table (Nodes (J)).Uname); 2824 Write_Eol; 2825 end loop; 2826 end if; 2827 2828 pragma Assert (Nodes (Nodes'First) = Root); 2829 pragma Assert (UNR.Table (Root).Nodes = null); 2830 UNR.Table (Root).Nodes := new Unit_Id_Array'(Nodes); 2831 2832 for J in Nodes'Range loop 2833 pragma Assert (SCC (Nodes (J)) = No_Unit_Id); 2834 UNR.Table (Nodes (J)).SCC_Root := Root; 2835 end loop; 2836 end Create_SCC; 2837 2838 ---------------- 2839 -- Successors -- 2840 ---------------- 2841 2842 function Successors (U : Unit_Id) return Unit_Id_Array is 2843 S : Successor_Id := UNR.Table (U).Successors; 2844 Tab : Unit_Id_Table; 2845 2846 begin 2847 -- Pretend that a spec is a successor of its body (even though it 2848 -- isn't), just so both get included. 2849 2850 if Units.Table (U).Utype = Is_Body then 2851 Append (Tab, Corresponding_Spec (U)); 2852 end if; 2853 2854 -- Now include the real successors 2855 2856 while S /= No_Successor loop 2857 pragma Assert (Succ.Table (S).Before = U); 2858 Append (Tab, Succ.Table (S).After); 2859 S := Succ.Table (S).Next; 2860 end loop; 2861 2862 declare 2863 Result : constant Unit_Id_Array := Tab.Table (1 .. Last (Tab)); 2864 2865 begin 2866 Free (Tab); 2867 return Result; 2868 end; 2869 end Successors; 2870 2871 ----------------------- 2872 -- Init_SCC_Num_Pred -- 2873 ----------------------- 2874 2875 procedure Init_SCC_Num_Pred (U : Unit_Id) is 2876 begin 2877 if UNR.Table (U).Visited then 2878 return; 2879 end if; 2880 2881 UNR.Table (U).Visited := True; 2882 2883 declare 2884 S : Successor_Id := UNR.Table (U).Successors; 2885 2886 begin 2887 while S /= No_Successor loop 2888 pragma Assert (Succ.Table (S).Before = U); 2889 Init_SCC_Num_Pred (Succ.Table (S).After); 2890 2891 if SCC (U) /= SCC (Succ.Table (S).After) then 2892 UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred := 2893 UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred + 1; 2894 end if; 2895 2896 S := Succ.Table (S).Next; 2897 end loop; 2898 end; 2899 end Init_SCC_Num_Pred; 2900 2901 -- Start of processing for Compute_Unit_SCCs 2902 2903 begin 2904 Compute_SCCs; 2905 2906 for Uref in UNR.First .. UNR.Last loop 2907 pragma Assert (not UNR.Table (Uref).Visited); 2908 null; 2909 end loop; 2910 2911 for Uref in UNR.First .. UNR.Last loop 2912 Init_SCC_Num_Pred (Uref); 2913 end loop; 2914 2915 -- Assert that SCC_Root of all units has been set to a valid unit, 2916 -- and that SCC_Num_Pred has not been modified in non-root units. 2917 2918 for Uref in UNR.First .. UNR.Last loop 2919 pragma Assert (UNR.Table (Uref).SCC_Root /= No_Unit_Id); 2920 pragma Assert (UNR.Table (Uref).SCC_Root in UNR.First .. UNR.Last); 2921 2922 if SCC (Uref) /= Uref then 2923 pragma Assert (UNR.Table (Uref).SCC_Num_Pred = 0); 2924 null; 2925 end if; 2926 end loop; 2927 end Compute_Unit_SCCs; 2928 2929 -------------------------- 2930 -- Find_Elab_All_Errors -- 2931 -------------------------- 2932 2933 procedure Find_Elab_All_Errors is 2934 Withed_Unit : Unit_Id; 2935 2936 begin 2937 for U in Units.First .. Units.Last loop 2938 2939 -- If this unit is not an interface to a stand-alone library, 2940 -- process WITH references for this unit ignoring interfaces to 2941 -- stand-alone libraries. 2942 2943 if not Units.Table (U).SAL_Interface then 2944 for W in Units.Table (U).First_With .. 2945 Units.Table (U).Last_With 2946 loop 2947 if Withs.Table (W).Sfile /= No_File 2948 and then (not Withs.Table (W).SAL_Interface) 2949 then 2950 -- Check for special case of withing a unit that does not 2951 -- exist any more. 2952 2953 if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then 2954 goto Next_With; 2955 end if; 2956 2957 Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname); 2958 2959 -- If it's Elaborate_All or Elab_All_Desirable, check 2960 -- that the withER and withEE are not in the same SCC. 2961 2962 if Withs.Table (W).Elaborate_All 2963 or else Withs.Table (W).Elab_All_Desirable 2964 then 2965 if SCC (U) = SCC (Withed_Unit) then 2966 Elab_Cycle_Found := True; -- ??? 2967 2968 -- We could probably give better error messages 2969 -- than Elab_Old here, but for now, to avoid 2970 -- disruption, we don't give any error here. 2971 -- Instead, we set the Elab_Cycle_Found flag above, 2972 -- and then run the Elab_Old algorithm to issue the 2973 -- error message. Ideally, we would like to print 2974 -- multiple errors rather than stopping after the 2975 -- first cycle. 2976 2977 if False then 2978 Error_Msg_Output 2979 ("illegal pragma Elaborate_All", 2980 Info => False); 2981 end if; 2982 end if; 2983 end if; 2984 end if; 2985 2986 <<Next_With>> 2987 null; 2988 end loop; 2989 end if; 2990 end loop; 2991 end Find_Elab_All_Errors; 2992 2993 --------------------- 2994 -- Find_Elab_Order -- 2995 --------------------- 2996 2997 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is 2998 Best_So_Far : Unit_Id; 2999 U : Unit_Id; 3000 3001 begin 3002 -- Gather dependencies and output them if option set 3003 3004 Gather_Dependencies; 3005 3006 Compute_Unit_SCCs; 3007 3008 -- Initialize the no-predecessor list 3009 3010 No_Pred := No_Unit_Id; 3011 for U in UNR.First .. UNR.Last loop 3012 if UNR.Table (U).Num_Pred = 0 then 3013 UNR.Table (U).Nextnp := No_Pred; 3014 No_Pred := U; 3015 end if; 3016 end loop; 3017 3018 -- OK, now we determine the elaboration order proper. All we do is to 3019 -- select the best choice from the no-predecessor list until all the 3020 -- nodes have been chosen. 3021 3022 Outer : loop 3023 if Debug_Flag_N then 3024 Write_Line ("Outer loop"); 3025 end if; 3026 3027 -- If there are no nodes with predecessors, then either we are 3028 -- done, as indicated by Num_Left being set to zero, or we have 3029 -- a circularity. In the latter case, diagnose the circularity, 3030 -- removing it from the graph and continue. 3031 -- ????But Diagnose_Elaboration_Problem always raises an 3032 -- exception, so the loop never goes around more than once. 3033 3034 Get_No_Pred : while No_Pred = No_Unit_Id loop 3035 exit Outer when Num_Left < 1; 3036 Diagnose_Elaboration_Problem (Elab_Order); 3037 end loop Get_No_Pred; 3038 3039 U := No_Pred; 3040 Best_So_Far := No_Unit_Id; 3041 3042 -- Loop to choose best entry in No_Pred list 3043 3044 No_Pred_Search : loop 3045 if Debug_Flag_N then 3046 Write_Str (" considering choice of "); 3047 Write_Unit_Name (Units.Table (U).Uname); 3048 Write_Eol; 3049 3050 if Units.Table (U).Elaborate_Body then 3051 Write_Str 3052 (" Elaborate_Body = True, Num_Pred for body = "); 3053 Write_Int 3054 (UNR.Table (Corresponding_Body (U)).Num_Pred); 3055 else 3056 Write_Str 3057 (" Elaborate_Body = False"); 3058 end if; 3059 3060 Write_Eol; 3061 end if; 3062 3063 -- Don't even consider units whose SCC is not ready. This 3064 -- ensures that all units of an SCC will be elaborated 3065 -- together, with no other units in between. 3066 3067 if SCC_Num_Pred (U) = 0 3068 and then Better_Choice (U, Best_So_Far) 3069 then 3070 if Debug_Flag_N then 3071 Write_Line (" tentatively chosen (best so far)"); 3072 end if; 3073 3074 Best_So_Far := U; 3075 else 3076 if Debug_Flag_N then 3077 Write_Line (" SCC not ready"); 3078 end if; 3079 end if; 3080 3081 U := UNR.Table (U).Nextnp; 3082 exit No_Pred_Search when U = No_Unit_Id; 3083 end loop No_Pred_Search; 3084 3085 -- If there are no units on the No_Pred list whose SCC is ready, 3086 -- there must be a cycle. Defer to Elab_Old to print an error 3087 -- message. 3088 3089 if Best_So_Far = No_Unit_Id then 3090 Elab_Cycle_Found := True; 3091 return; 3092 end if; 3093 3094 -- Choose the best candidate found 3095 3096 Choose (Elab_Order, Best_So_Far, " [Best_So_Far]"); 3097 3098 -- If it's a spec with a body, and the body is not yet chosen, 3099 -- choose the body if possible. The case where the body is 3100 -- already chosen is Elaborate_Body; the above call to Choose 3101 -- the spec will also Choose the body. 3102 3103 if Units.Table (Best_So_Far).Utype = Is_Spec 3104 and then UNR.Table 3105 (Corresponding_Body (Best_So_Far)).Elab_Position = 0 3106 then 3107 declare 3108 Choose_The_Body : constant Boolean := 3109 UNR.Table (Corresponding_Body 3110 (Best_So_Far)).Num_Pred = 0; 3111 3112 begin 3113 if Debug_Flag_B then 3114 Write_Str ("Can we choose the body?... "); 3115 3116 if Choose_The_Body then 3117 Write_Line ("Yes!"); 3118 else 3119 Write_Line ("No."); 3120 end if; 3121 end if; 3122 3123 if Choose_The_Body then 3124 Choose 3125 (Elab_Order => Elab_Order, 3126 Chosen => Corresponding_Body (Best_So_Far), 3127 Msg => " [body]"); 3128 end if; 3129 end; 3130 end if; 3131 3132 -- Finally, choose all the rest of the units in the same SCC as 3133 -- Best_So_Far. If it hasn't been chosen (Elab_Position = 0), and 3134 -- it's ready to be chosen (Num_Pred = 0), then we can choose it. 3135 3136 loop 3137 declare 3138 Chose_One_Or_More : Boolean := False; 3139 SCC : Unit_Id_Array renames Nodes (Best_So_Far).all; 3140 3141 begin 3142 for J in SCC'Range loop 3143 if UNR.Table (SCC (J)).Elab_Position = 0 3144 and then UNR.Table (SCC (J)).Num_Pred = 0 3145 then 3146 Chose_One_Or_More := True; 3147 Choose (Elab_Order, SCC (J), " [same SCC]"); 3148 end if; 3149 end loop; 3150 3151 exit when not Chose_One_Or_More; 3152 end; 3153 end loop; 3154 end loop Outer; 3155 3156 Find_Elab_All_Errors; 3157 end Find_Elab_Order; 3158 3159 ----------- 3160 -- Nodes -- 3161 ----------- 3162 3163 function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr is 3164 begin 3165 return UNR.Table (SCC (U)).Nodes; 3166 end Nodes; 3167 3168 --------- 3169 -- SCC -- 3170 --------- 3171 3172 function SCC (U : Unit_Id) return Unit_Id is 3173 begin 3174 return UNR.Table (U).SCC_Root; 3175 end SCC; 3176 3177 ------------------ 3178 -- SCC_Num_Pred -- 3179 ------------------ 3180 3181 function SCC_Num_Pred (U : Unit_Id) return Int is 3182 begin 3183 return UNR.Table (SCC (U)).SCC_Num_Pred; 3184 end SCC_Num_Pred; 3185 3186 --------------- 3187 -- Write_SCC -- 3188 --------------- 3189 3190 procedure Write_SCC (U : Unit_Id) is 3191 pragma Assert (SCC (U) = U); 3192 begin 3193 for J in Nodes (U)'Range loop 3194 Write_Int (UNR.Table (Nodes (U) (J)).Elab_Position); 3195 Write_Str (". "); 3196 Write_Unit_Name (Units.Table (Nodes (U) (J)).Uname); 3197 Write_Eol; 3198 end loop; 3199 3200 Write_Eol; 3201 end Write_SCC; 3202 3203 end Elab_New; 3204 3205 -------------- 3206 -- Elab_Old -- 3207 -------------- 3208 3209 package body Elab_Old is 3210 3211 --------------------- 3212 -- Find_Elab_Order -- 3213 --------------------- 3214 3215 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is 3216 Best_So_Far : Unit_Id; 3217 U : Unit_Id; 3218 3219 begin 3220 -- Gather dependencies and output them if option set 3221 3222 Gather_Dependencies; 3223 3224 -- Initialize the no-predecessor list 3225 3226 No_Pred := No_Unit_Id; 3227 for U in UNR.First .. UNR.Last loop 3228 if UNR.Table (U).Num_Pred = 0 then 3229 UNR.Table (U).Nextnp := No_Pred; 3230 No_Pred := U; 3231 end if; 3232 end loop; 3233 3234 -- OK, now we determine the elaboration order proper. All we do is to 3235 -- select the best choice from the no-predecessor list until all the 3236 -- nodes have been chosen. 3237 3238 Outer : loop 3239 3240 -- If there are no nodes with predecessors, then either we are 3241 -- done, as indicated by Num_Left being set to zero, or we have 3242 -- a circularity. In the latter case, diagnose the circularity, 3243 -- removing it from the graph and continue. 3244 -- ????But Diagnose_Elaboration_Problem always raises an 3245 -- exception, so the loop never goes around more than once. 3246 3247 Get_No_Pred : while No_Pred = No_Unit_Id loop 3248 exit Outer when Num_Left < 1; 3249 Diagnose_Elaboration_Problem (Elab_Order); 3250 end loop Get_No_Pred; 3251 3252 U := No_Pred; 3253 Best_So_Far := No_Unit_Id; 3254 3255 -- Loop to choose best entry in No_Pred list 3256 3257 No_Pred_Search : loop 3258 if Debug_Flag_N then 3259 Write_Str (" considering choice of "); 3260 Write_Unit_Name (Units.Table (U).Uname); 3261 Write_Eol; 3262 3263 if Units.Table (U).Elaborate_Body then 3264 Write_Str 3265 (" Elaborate_Body = True, Num_Pred for body = "); 3266 Write_Int 3267 (UNR.Table (Corresponding_Body (U)).Num_Pred); 3268 else 3269 Write_Str 3270 (" Elaborate_Body = False"); 3271 end if; 3272 3273 Write_Eol; 3274 end if; 3275 3276 -- This is a candididate to be considered for choice 3277 3278 if Better_Choice (U, Best_So_Far) then 3279 if Debug_Flag_N then 3280 Write_Line (" tentatively chosen (best so far)"); 3281 end if; 3282 3283 Best_So_Far := U; 3284 end if; 3285 3286 U := UNR.Table (U).Nextnp; 3287 exit No_Pred_Search when U = No_Unit_Id; 3288 end loop No_Pred_Search; 3289 3290 -- Choose the best candidate found 3291 3292 Choose (Elab_Order, Best_So_Far, " [Elab_Old Best_So_Far]"); 3293 end loop Outer; 3294 end Find_Elab_Order; 3295 3296 end Elab_Old; 3297 3298end Binde; 3299