1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- B I N D E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, 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 1127 -- If this unit is an interface to a stand-alone library, then we 1128 -- don't want to elaborate the body -- that will happen as part of 1129 -- the library. 1130 1131 elsif Units.Table (Chosen).SAL_Interface then 1132 null; 1133 1134 else 1135 Choose 1136 (Elab_Order => Elab_Order, 1137 Chosen => Corresponding_Body (Chosen), 1138 Msg => " [Elaborate_Body]"); 1139 end if; 1140 end if; 1141 end Choose; 1142 1143 ------------------------ 1144 -- Corresponding_Body -- 1145 ------------------------ 1146 1147 -- Currently if the body and spec are separate, then they appear as two 1148 -- separate units in the same ALI file, with the body appearing first and 1149 -- the spec appearing second. 1150 1151 function Corresponding_Body (U : Unit_Id) return Unit_Id is 1152 begin 1153 pragma Assert (Units.Table (U).Utype = Is_Spec); 1154 return U - 1; 1155 end Corresponding_Body; 1156 1157 ------------------------ 1158 -- Corresponding_Spec -- 1159 ------------------------ 1160 1161 -- Currently if the body and spec are separate, then they appear as two 1162 -- separate units in the same ALI file, with the body appearing first and 1163 -- the spec appearing second. 1164 1165 function Corresponding_Spec (U : Unit_Id) return Unit_Id is 1166 begin 1167 pragma Assert (Units.Table (U).Utype = Is_Body); 1168 return U + 1; 1169 end Corresponding_Spec; 1170 1171 -------------------- 1172 -- Debug_Flag_Old -- 1173 -------------------- 1174 1175 function Debug_Flag_Old return Boolean is 1176 begin 1177 -- If the user specified both flags, we want to use the older algorithm, 1178 -- rather than some confusing mix of the two. 1179 1180 return Debug_Flag_P and not Debug_Flag_O; 1181 end Debug_Flag_Old; 1182 1183 ---------------------- 1184 -- Debug_Flag_Older -- 1185 ---------------------- 1186 1187 function Debug_Flag_Older return Boolean is 1188 begin 1189 return Debug_Flag_O; 1190 end Debug_Flag_Older; 1191 1192 ---------------------------------- 1193 -- Diagnose_Elaboration_Problem -- 1194 ---------------------------------- 1195 1196 procedure Diagnose_Elaboration_Problem 1197 (Elab_Order : in out Unit_Id_Table) 1198 is 1199 function Find_Path 1200 (Ufrom : Unit_Id; 1201 Uto : Unit_Id; 1202 ML : Nat) return Boolean; 1203 -- Recursive routine used to find a path from node Ufrom to node Uto. 1204 -- If a path exists, returns True and outputs an appropriate set of 1205 -- error messages giving the path. Also calls Choose for each of the 1206 -- nodes so that they get removed from the remaining set. There are 1207 -- two cases of calls, either Ufrom = Uto for an attempt to find a 1208 -- cycle, or Ufrom is a spec and Uto the corresponding body for the 1209 -- case of an unsatisfiable Elaborate_Body pragma. ML is the minimum 1210 -- acceptable length for a path. 1211 1212 --------------- 1213 -- Find_Path -- 1214 --------------- 1215 1216 function Find_Path 1217 (Ufrom : Unit_Id; 1218 Uto : Unit_Id; 1219 ML : Nat) return Boolean 1220 is 1221 function Find_Link (U : Unit_Id; PL : Nat) return Boolean; 1222 -- This is the inner recursive routine, it determines if a path 1223 -- exists from U to Uto, and if so returns True and outputs the 1224 -- appropriate set of error messages. PL is the path length 1225 1226 --------------- 1227 -- Find_Link -- 1228 --------------- 1229 1230 function Find_Link (U : Unit_Id; PL : Nat) return Boolean is 1231 S : Successor_Id; 1232 1233 begin 1234 -- Recursion ends if we are at terminating node and the path is 1235 -- sufficiently long, generate error message and return True. 1236 1237 if U = Uto and then PL >= ML then 1238 Choose (Elab_Order, U, " [Find_Link: base]"); 1239 return True; 1240 1241 -- All done if already visited 1242 1243 elsif UNR.Table (U).Visited then 1244 return False; 1245 1246 -- Otherwise mark as visited and look at all successors 1247 1248 else 1249 UNR.Table (U).Visited := True; 1250 1251 S := UNR.Table (U).Successors; 1252 while S /= No_Successor loop 1253 if Find_Link (Succ.Table (S).After, PL + 1) then 1254 Elab_Error_Msg (S); 1255 Choose (Elab_Order, U, " [Find_Link: recursive]"); 1256 return True; 1257 end if; 1258 1259 S := Succ.Table (S).Next; 1260 end loop; 1261 1262 -- Falling through means this does not lead to a path 1263 1264 return False; 1265 end if; 1266 end Find_Link; 1267 1268 -- Start of processing for Find_Path 1269 1270 begin 1271 -- Initialize all non-chosen nodes to not visited yet 1272 1273 for U in Units.First .. Units.Last loop 1274 UNR.Table (U).Visited := UNR.Table (U).Elab_Position /= 0; 1275 end loop; 1276 1277 -- Now try to find the path 1278 1279 return Find_Link (Ufrom, 0); 1280 end Find_Path; 1281 1282 -- Start of processing for Diagnose_Elaboration_Problem 1283 1284 begin 1285 Diagnose_Elaboration_Problem_Called := True; 1286 Set_Standard_Error; 1287 1288 -- Output state of things if debug flag N set 1289 1290 if Debug_Flag_N then 1291 declare 1292 NP : Int; 1293 1294 begin 1295 Write_Eol; 1296 Write_Eol; 1297 Write_Line ("Diagnose_Elaboration_Problem called"); 1298 Write_Line ("List of remaining unchosen units and predecessors"); 1299 1300 for U in Units.First .. Units.Last loop 1301 if UNR.Table (U).Elab_Position = 0 then 1302 NP := UNR.Table (U).Num_Pred; 1303 Write_Eol; 1304 Write_Str (" Unchosen unit: #"); 1305 Write_Int (Int (U)); 1306 Write_Str (" "); 1307 Write_Unit_Name (Units.Table (U).Uname); 1308 Write_Str (" (Num_Pred = "); 1309 Write_Int (NP); 1310 Write_Line (")"); 1311 1312 if NP = 0 then 1313 if Units.Table (U).Elaborate_Body then 1314 Write_Line 1315 (" (not chosen because of Elaborate_Body)"); 1316 else 1317 Write_Line (" ****************** why not chosen?"); 1318 end if; 1319 end if; 1320 1321 -- Search links list to find unchosen predecessors 1322 1323 for S in Succ.First .. Succ.Last loop 1324 declare 1325 SL : Successor_Link renames Succ.Table (S); 1326 1327 begin 1328 if SL.After = U 1329 and then UNR.Table (SL.Before).Elab_Position = 0 1330 then 1331 Write_Str (" unchosen predecessor: #"); 1332 Write_Int (Int (SL.Before)); 1333 Write_Str (" "); 1334 Write_Unit_Name (Units.Table (SL.Before).Uname); 1335 Write_Eol; 1336 NP := NP - 1; 1337 end if; 1338 end; 1339 end loop; 1340 1341 if NP /= 0 then 1342 Write_Line (" **************** Num_Pred value wrong!"); 1343 end if; 1344 end if; 1345 end loop; 1346 end; 1347 end if; 1348 1349 -- Output the header for the error, and manually increment the error 1350 -- count. We are using Error_Msg_Output rather than Error_Msg here for 1351 -- two reasons: 1352 1353 -- This is really only one error, not one for each line 1354 -- We want this output on standard output since it is voluminous 1355 1356 -- But we do need to deal with the error count manually in this case 1357 1358 Errors_Detected := Errors_Detected + 1; 1359 Error_Msg_Output ("elaboration circularity detected", Info => False); 1360 1361 -- Try to find cycles starting with any of the remaining nodes that have 1362 -- not yet been chosen. There must be at least one (there is some reason 1363 -- we are being called). 1364 1365 for U in Units.First .. Units.Last loop 1366 if UNR.Table (U).Elab_Position = 0 then 1367 if Find_Path (U, U, 1) then 1368 raise Unrecoverable_Error; 1369 end if; 1370 end if; 1371 end loop; 1372 1373 -- We should never get here, since we were called for some reason, and 1374 -- we should have found and eliminated at least one bad path. 1375 1376 raise Program_Error; 1377 end Diagnose_Elaboration_Problem; 1378 1379 -------------------- 1380 -- Elab_All_Links -- 1381 -------------------- 1382 1383 procedure Elab_All_Links 1384 (Before : Unit_Id; 1385 After : Unit_Id; 1386 Reason : Succ_Reason; 1387 Link : Elab_All_Id) 1388 is 1389 begin 1390 if UNR.Table (Before).Visited then 1391 return; 1392 end if; 1393 1394 -- Build the direct link for Before 1395 1396 UNR.Table (Before).Visited := True; 1397 Build_Link (Before, After, Reason, Link); 1398 1399 -- Process all units with'ed by Before recursively 1400 1401 for W in Units.Table (Before).First_With .. 1402 Units.Table (Before).Last_With 1403 loop 1404 -- Skip if this with is an interface to a stand-alone library. Skip 1405 -- also if no ALI file for this WITH, happens for language defined 1406 -- generics while bootstrapping the compiler (see body of routine 1407 -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited with 1408 -- clause, which does not impose an elaboration link. 1409 1410 if not Withs.Table (W).SAL_Interface 1411 and then Withs.Table (W).Afile /= No_File 1412 and then not Withs.Table (W).Limited_With 1413 then 1414 declare 1415 Info : constant Int := 1416 Get_Name_Table_Int (Withs.Table (W).Uname); 1417 1418 begin 1419 -- If the unit is unknown, for some unknown reason, fail 1420 -- graciously explaining that the unit is unknown. Without 1421 -- this check, gnatbind will crash in Unit_Id_Of. 1422 1423 if Info = 0 or else Unit_Id (Info) = No_Unit_Id then 1424 declare 1425 Withed : String := 1426 Get_Name_String (Withs.Table (W).Uname); 1427 Last_Withed : Natural := Withed'Last; 1428 Withing : String := 1429 Get_Name_String 1430 (Units.Table (Before).Uname); 1431 Last_Withing : Natural := Withing'Last; 1432 Spec_Body : String := " (Spec)"; 1433 1434 begin 1435 To_Mixed (Withed); 1436 To_Mixed (Withing); 1437 1438 if Last_Withed > 2 1439 and then Withed (Last_Withed - 1) = '%' 1440 then 1441 Last_Withed := Last_Withed - 2; 1442 end if; 1443 1444 if Last_Withing > 2 1445 and then Withing (Last_Withing - 1) = '%' 1446 then 1447 Last_Withing := Last_Withing - 2; 1448 end if; 1449 1450 if Units.Table (Before).Utype = Is_Body 1451 or else Units.Table (Before).Utype = Is_Body_Only 1452 then 1453 Spec_Body := " (Body)"; 1454 end if; 1455 1456 Osint.Fail 1457 ("could not find unit " 1458 & Withed (Withed'First .. Last_Withed) & " needed by " 1459 & Withing (Withing'First .. Last_Withing) & Spec_Body); 1460 end; 1461 end if; 1462 1463 Elab_All_Links 1464 (Unit_Id_Of (Withs.Table (W).Uname), 1465 After, 1466 Reason, 1467 Make_Elab_All_Entry (Withs.Table (W).Uname, Link)); 1468 end; 1469 end if; 1470 end loop; 1471 1472 -- Process corresponding body, if there is one 1473 1474 if Units.Table (Before).Utype = Is_Spec then 1475 Elab_All_Links 1476 (Corresponding_Body (Before), 1477 After, Reason, 1478 Make_Elab_All_Entry 1479 (Units.Table (Corresponding_Body (Before)).Uname, Link)); 1480 end if; 1481 end Elab_All_Links; 1482 1483 -------------------- 1484 -- Elab_Error_Msg -- 1485 -------------------- 1486 1487 procedure Elab_Error_Msg (S : Successor_Id) is 1488 SL : Successor_Link renames Succ.Table (S); 1489 1490 begin 1491 -- Nothing to do if internal unit involved and no -da flag 1492 1493 if not Debug_Flag_A 1494 and then 1495 (Is_Internal_File_Name (Units.Table (SL.Before).Sfile) 1496 or else 1497 Is_Internal_File_Name (Units.Table (SL.After).Sfile)) 1498 then 1499 return; 1500 end if; 1501 1502 -- Here we want to generate output 1503 1504 Error_Msg_Unit_1 := Units.Table (SL.Before).Uname; 1505 1506 if SL.Elab_Body then 1507 Error_Msg_Unit_2 := Units.Table (Corresponding_Body (SL.After)).Uname; 1508 else 1509 Error_Msg_Unit_2 := Units.Table (SL.After).Uname; 1510 end if; 1511 1512 Error_Msg_Output (" $ must be elaborated before $", Info => True); 1513 1514 Error_Msg_Unit_1 := Units.Table (SL.Reason_Unit).Uname; 1515 1516 case SL.Reason is 1517 when Withed => 1518 Error_Msg_Output 1519 (" reason: with clause", 1520 Info => True); 1521 1522 when Forced => 1523 Error_Msg_Output 1524 (" reason: forced by -f switch", 1525 Info => True); 1526 1527 when Elab => 1528 Error_Msg_Output 1529 (" reason: pragma Elaborate in unit $", 1530 Info => True); 1531 1532 when Elab_All => 1533 Error_Msg_Output 1534 (" reason: pragma Elaborate_All in unit $", 1535 Info => True); 1536 1537 when Elab_All_Desirable => 1538 Error_Msg_Output 1539 (" reason: implicit Elaborate_All in unit $", 1540 Info => True); 1541 1542 Error_Msg_Output 1543 (" recompile $ with -gnatel for full details", 1544 Info => True); 1545 1546 when Elab_Desirable => 1547 Error_Msg_Output 1548 (" reason: implicit Elaborate in unit $", 1549 Info => True); 1550 1551 Error_Msg_Output 1552 (" recompile $ with -gnatel for full details", 1553 Info => True); 1554 1555 when Spec_First => 1556 Error_Msg_Output 1557 (" reason: spec always elaborated before body", 1558 Info => True); 1559 end case; 1560 1561 Write_Elab_All_Chain (S); 1562 1563 if SL.Elab_Body then 1564 Error_Msg_Unit_1 := Units.Table (SL.Before).Uname; 1565 Error_Msg_Unit_2 := Units.Table (SL.After).Uname; 1566 Error_Msg_Output 1567 (" $ must therefore be elaborated before $", True); 1568 1569 Error_Msg_Unit_1 := Units.Table (SL.After).Uname; 1570 Error_Msg_Output 1571 (" (because $ has a pragma Elaborate_Body)", True); 1572 end if; 1573 1574 if not Zero_Formatting then 1575 Write_Eol; 1576 end if; 1577 end Elab_Error_Msg; 1578 1579 --------------------- 1580 -- Find_Elab_Order -- 1581 --------------------- 1582 1583 procedure Find_Elab_Order 1584 (Elab_Order : out Unit_Id_Table; 1585 First_Main_Lib_File : File_Name_Type) 1586 is 1587 function Num_Spec_Body_Pairs (Order : Unit_Id_Array) return Nat; 1588 -- Number of cases where the body of a unit immediately follows the 1589 -- corresponding spec. Such cases are good, because calls to that unit 1590 -- from outside can't get ABE. 1591 1592 ------------------------- 1593 -- Num_Spec_Body_Pairs -- 1594 ------------------------- 1595 1596 function Num_Spec_Body_Pairs (Order : Unit_Id_Array) return Nat is 1597 Result : Nat := 0; 1598 1599 begin 1600 for J in Order'First + 1 .. Order'Last loop 1601 if Units.Table (Order (J - 1)).Utype = Is_Spec 1602 and then Units.Table (Order (J)).Utype = Is_Body 1603 and then Corresponding_Spec (Order (J)) = Order (J - 1) 1604 then 1605 Result := Result + 1; 1606 end if; 1607 end loop; 1608 1609 return Result; 1610 end Num_Spec_Body_Pairs; 1611 1612 -- Local variables 1613 1614 Old_Elab_Order : Unit_Id_Table; 1615 1616 -- Start of processing for Find_Elab_Order 1617 1618 begin 1619 -- Output warning if -p used with no -gnatE units 1620 1621 if Pessimistic_Elab_Order 1622 and not Dynamic_Elaboration_Checks_Specified 1623 then 1624 Error_Msg ("?use of -p switch questionable"); 1625 Error_Msg ("?since all units compiled with static elaboration model"); 1626 end if; 1627 1628 if Do_New and not Debug_Flag_Old and not Debug_Flag_Older then 1629 if Debug_Flag_V then 1630 Write_Line ("Doing new..."); 1631 end if; 1632 1633 Doing_New := True; 1634 Init; 1635 Elab_New.Find_Elab_Order (Elab_Order); 1636 end if; 1637 1638 -- Elab_New does not support the pessimistic order, so if that was 1639 -- requested, use the old results. Use Elab_Old if -dp or -do was 1640 -- selected. Elab_New does not yet give proper error messages for 1641 -- illegal Elaborate_Alls, so if there is one, run Elab_Old. 1642 1643 if Do_Old 1644 or Pessimistic_Elab_Order 1645 or Debug_Flag_Old 1646 or Debug_Flag_Older 1647 or Elab_Cycle_Found 1648 then 1649 if Debug_Flag_V then 1650 Write_Line ("Doing old..."); 1651 end if; 1652 1653 Doing_New := False; 1654 Init; 1655 Elab_Old.Find_Elab_Order (Old_Elab_Order); 1656 end if; 1657 1658 pragma Assert (Elab_Cycle_Found <= -- implies 1659 Diagnose_Elaboration_Problem_Called); 1660 1661 declare 1662 Old_Order : Unit_Id_Array renames 1663 Old_Elab_Order.Table (1 .. Last (Old_Elab_Order)); 1664 begin 1665 if Do_Old and Do_New then 1666 declare 1667 New_Order : Unit_Id_Array renames 1668 Elab_Order.Table (1 .. Last (Elab_Order)); 1669 Old_Pairs : constant Nat := Num_Spec_Body_Pairs (Old_Order); 1670 New_Pairs : constant Nat := Num_Spec_Body_Pairs (New_Order); 1671 1672 begin 1673 Write_Line (Get_Name_String (First_Main_Lib_File)); 1674 1675 pragma Assert (Old_Order'Length = New_Order'Length); 1676 pragma Debug (Validate (Old_Order, Doing_New => False)); 1677 pragma Debug (Validate (New_Order, Doing_New => True)); 1678 1679 -- Misc debug printouts that can be used for experimentation by 1680 -- changing the 'if's below. 1681 1682 if True then 1683 if New_Order = Old_Order then 1684 Write_Line ("Elab_New: same order."); 1685 else 1686 Write_Line ("Elab_New: diff order."); 1687 end if; 1688 end if; 1689 1690 if New_Order /= Old_Order and then False then 1691 Write_Line ("Elaboration orders differ:"); 1692 Write_Elab_Order 1693 (Old_Order, Title => "OLD ELABORATION ORDER"); 1694 Write_Elab_Order 1695 (New_Order, Title => "NEW ELABORATION ORDER"); 1696 end if; 1697 1698 if True then 1699 Write_Str ("Pairs: "); 1700 Write_Int (Old_Pairs); 1701 1702 if Old_Pairs = New_Pairs then 1703 Write_Str (" = "); 1704 elsif Old_Pairs < New_Pairs then 1705 Write_Str (" < "); 1706 else 1707 Write_Str (" > "); 1708 end if; 1709 1710 Write_Int (New_Pairs); 1711 Write_Eol; 1712 end if; 1713 1714 if Old_Pairs /= New_Pairs and then False then 1715 Write_Str ("Pairs: "); 1716 Write_Int (Old_Pairs); 1717 1718 if Old_Pairs < New_Pairs then 1719 Write_Str (" < "); 1720 else 1721 Write_Str (" > "); 1722 end if; 1723 1724 Write_Int (New_Pairs); 1725 Write_Eol; 1726 1727 if Old_Pairs /= New_Pairs and then Debug_Flag_V then 1728 Write_Elab_Order 1729 (Old_Order, Title => "OLD ELABORATION ORDER"); 1730 Write_Elab_Order 1731 (New_Order, Title => "NEW ELABORATION ORDER"); 1732 pragma Assert (New_Pairs >= Old_Pairs); 1733 end if; 1734 end if; 1735 end; 1736 end if; 1737 1738 -- The Elab_New algorithm doesn't implement the -p switch, so if that 1739 -- was used, use the results from the old algorithm. Likewise if the 1740 -- user has requested the old algorithm. 1741 1742 if Pessimistic_Elab_Order or Debug_Flag_Old or Debug_Flag_Older then 1743 pragma Assert 1744 (Last (Elab_Order) = 0 1745 or else Last (Elab_Order) = Old_Order'Last); 1746 1747 Init (Elab_Order); 1748 Append_All (Elab_Order, Old_Order); 1749 end if; 1750 1751 -- Now set the Elab_Positions in the Units table. It is important to 1752 -- do this late, in case we're running both Elab_New and Elab_Old. 1753 1754 declare 1755 New_Order : Unit_Id_Array renames 1756 Elab_Order.Table (1 .. Last (Elab_Order)); 1757 Units_Array : Units.Table_Type renames 1758 Units.Table (Units.First .. Units.Last); 1759 begin 1760 for J in New_Order'Range loop 1761 pragma Assert 1762 (UNR.Table (New_Order (J)).Elab_Position = J); 1763 Units_Array (New_Order (J)).Elab_Position := J; 1764 end loop; 1765 1766 if Errors_Detected = 0 then 1767 1768 -- Display elaboration order if -l was specified 1769 1770 if Elab_Order_Output then 1771 if Zero_Formatting then 1772 Write_Elab_Order (New_Order, Title => ""); 1773 else 1774 Write_Elab_Order 1775 (New_Order, Title => "ELABORATION ORDER"); 1776 end if; 1777 end if; 1778 1779 -- Display list of sources in the closure (except predefined 1780 -- sources) if -R was used. Include predefined sources if -Ra 1781 -- was used. 1782 1783 if List_Closure then 1784 Write_Closure (New_Order); 1785 end if; 1786 end if; 1787 end; 1788 end; 1789 end Find_Elab_Order; 1790 1791 ---------------------- 1792 -- Force_Elab_Order -- 1793 ---------------------- 1794 1795 procedure Force_Elab_Order is 1796 use System.OS_Lib; 1797 -- There is a lot of fiddly string manipulation below, because we don't 1798 -- want to depend on misc utility packages like Ada.Characters.Handling. 1799 1800 function Get_Line return String; 1801 -- Read the next line from the file content read by Read_File. Strip 1802 -- all leading and trailing blanks. Convert "(spec)" or "(body)" to 1803 -- "%s"/"%b". Remove comments (Ada style; "--" to end of line). 1804 1805 function Read_File (Name : String) return String_Ptr; 1806 -- Read the entire contents of the named file 1807 1808 subtype Header_Num is Unit_Name_Type'Base range 0 .. 2**16 - 1; 1809 type Line_Number is new Nat; 1810 No_Line_Number : constant Line_Number := 0; 1811 Cur_Line_Number : Line_Number := 0; 1812 -- Current line number in the Force_Elab_Order_File. 1813 -- Incremented by Get_Line. Used in error messages. 1814 1815 function Hash (N : Unit_Name_Type) return Header_Num; 1816 1817 package Name_Map is new System.HTable.Simple_HTable 1818 (Header_Num => Header_Num, 1819 Element => Line_Number, 1820 No_Element => No_Line_Number, 1821 Key => Unit_Name_Type, 1822 Hash => Hash, 1823 Equal => "="); 1824 -- Name_Map contains an entry for each file name seen, mapped to the 1825 -- line number where we saw it first. This is used to give an error for 1826 -- duplicates. 1827 1828 ---------- 1829 -- Hash -- 1830 ---------- 1831 1832 function Hash (N : Unit_Name_Type) return Header_Num is 1833 -- Name_Ids are already widely dispersed; no need for any actual 1834 -- hashing. Just subtract to make it zero based, and "mod" to 1835 -- bring it in range. 1836 begin 1837 return (N - Unit_Name_Type'First) mod (Header_Num'Last + 1); 1838 end Hash; 1839 1840 --------------- 1841 -- Read_File -- 1842 --------------- 1843 1844 function Read_File (Name : String) return String_Ptr is 1845 1846 -- All of the following calls should succeed, because we checked the 1847 -- file in Switch.B, but we double check and raise Program_Error on 1848 -- failure, just in case. 1849 1850 F : constant File_Descriptor := Open_Read (Name, Binary); 1851 1852 begin 1853 if F = Invalid_FD then 1854 raise Program_Error; 1855 end if; 1856 1857 declare 1858 Len : constant Natural := Natural (File_Length (F)); 1859 Result : constant String_Ptr := new String (1 .. Len); 1860 Len_Read : constant Natural := 1861 Read (F, Result (1)'Address, Len); 1862 1863 Status : Boolean; 1864 1865 begin 1866 if Len_Read /= Len then 1867 raise Program_Error; 1868 end if; 1869 1870 Close (F, Status); 1871 1872 if not Status then 1873 raise Program_Error; 1874 end if; 1875 1876 return Result; 1877 end; 1878 end Read_File; 1879 1880 Cur : Positive := 1; 1881 S : String_Ptr := Read_File (Force_Elab_Order_File.all); 1882 1883 -------------- 1884 -- Get_Line -- 1885 -------------- 1886 1887 function Get_Line return String is 1888 First : Positive := Cur; 1889 Last : Natural; 1890 1891 begin 1892 Cur_Line_Number := Cur_Line_Number + 1; 1893 1894 -- Skip to end of line 1895 1896 while Cur <= S'Last 1897 and then S (Cur) /= ASCII.LF 1898 and then S (Cur) /= ASCII.CR 1899 loop 1900 Cur := Cur + 1; 1901 end loop; 1902 1903 -- Strip leading blanks 1904 1905 while First <= S'Last and then S (First) = ' ' loop 1906 First := First + 1; 1907 end loop; 1908 1909 -- Strip trailing blanks and comment 1910 1911 Last := Cur - 1; 1912 1913 for J in First .. Last - 1 loop 1914 if S (J .. J + 1) = "--" then 1915 Last := J - 1; 1916 exit; 1917 end if; 1918 end loop; 1919 1920 while Last >= First and then S (Last) = ' ' loop 1921 Last := Last - 1; 1922 end loop; 1923 1924 -- Convert "(spec)" or "(body)" to "%s"/"%b", strip trailing blanks 1925 -- again. 1926 1927 declare 1928 Body_String : constant String := "(body)"; 1929 BL : constant Positive := Body_String'Length; 1930 Spec_String : constant String := "(spec)"; 1931 SL : constant Positive := Spec_String'Length; 1932 1933 Line : String renames S (First .. Last); 1934 1935 Is_Body : Boolean := False; 1936 Is_Spec : Boolean := False; 1937 1938 begin 1939 if Line'Length >= SL 1940 and then Line (Last - SL + 1 .. Last) = Spec_String 1941 then 1942 Is_Spec := True; 1943 Last := Last - SL; 1944 elsif Line'Length >= BL 1945 and then Line (Last - BL + 1 .. Last) = Body_String 1946 then 1947 Is_Body := True; 1948 Last := Last - BL; 1949 end if; 1950 1951 while Last >= First and then S (Last) = ' ' loop 1952 Last := Last - 1; 1953 end loop; 1954 1955 -- Skip past LF or CR/LF 1956 1957 if Cur <= S'Last and then S (Cur) = ASCII.CR then 1958 Cur := Cur + 1; 1959 end if; 1960 1961 if Cur <= S'Last and then S (Cur) = ASCII.LF then 1962 Cur := Cur + 1; 1963 end if; 1964 1965 if Is_Spec then 1966 return Line (First .. Last) & "%s"; 1967 elsif Is_Body then 1968 return Line (First .. Last) & "%b"; 1969 else 1970 return Line; 1971 end if; 1972 end; 1973 end Get_Line; 1974 1975 -- Local variables 1976 1977 Empty_Name : constant Unit_Name_Type := Name_Find (""); 1978 Prev_Unit : Unit_Id := No_Unit_Id; 1979 1980 -- Start of processing for Force_Elab_Order 1981 1982 begin 1983 -- Loop through the file content, and build a dependency link for each 1984 -- pair of lines. Ignore lines that should be ignored. 1985 1986 while Cur <= S'Last loop 1987 declare 1988 Uname : constant Unit_Name_Type := Name_Find (Get_Line); 1989 Error : Boolean := False; 1990 1991 begin 1992 if Uname = Empty_Name then 1993 null; -- silently skip blank lines 1994 else 1995 declare 1996 Dup : constant Line_Number := Name_Map.Get (Uname); 1997 begin 1998 if Dup = No_Line_Number then 1999 Name_Map.Set (Uname, Cur_Line_Number); 2000 2001 -- We don't need to give the "not present" message in 2002 -- the case of "duplicate unit", because we would have 2003 -- already given the "not present" message on the 2004 -- first occurrence. 2005 2006 if Get_Name_Table_Int (Uname) = 0 2007 or else Unit_Id (Get_Name_Table_Int (Uname)) = 2008 No_Unit_Id 2009 then 2010 Error := True; 2011 if Doing_New then 2012 Write_Line 2013 ("""" & Get_Name_String (Uname) 2014 & """: not present; ignored"); 2015 end if; 2016 end if; 2017 2018 else 2019 Error := True; 2020 if Doing_New then 2021 Error_Msg_Nat_1 := Nat (Cur_Line_Number); 2022 Error_Msg_Unit_1 := Uname; 2023 Error_Msg_Nat_2 := Nat (Dup); 2024 Error_Msg 2025 (Force_Elab_Order_File.all 2026 & ":#: duplicate unit name $ from line #"); 2027 end if; 2028 end if; 2029 end; 2030 2031 if not Error then 2032 declare 2033 Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname); 2034 begin 2035 if Is_Internal_File_Name 2036 (Units.Table (Cur_Unit).Sfile) 2037 then 2038 if Doing_New then 2039 Write_Line 2040 ("""" & Get_Name_String (Uname) 2041 & """: predefined unit ignored"); 2042 end if; 2043 2044 else 2045 if Prev_Unit /= No_Unit_Id then 2046 if Doing_New then 2047 Write_Unit_Name (Units.Table (Prev_Unit).Uname); 2048 Write_Str (" <-- "); 2049 Write_Unit_Name (Units.Table (Cur_Unit).Uname); 2050 Write_Eol; 2051 end if; 2052 2053 Build_Link 2054 (Before => Prev_Unit, 2055 After => Cur_Unit, 2056 R => Forced); 2057 end if; 2058 2059 Prev_Unit := Cur_Unit; 2060 end if; 2061 end; 2062 end if; 2063 end if; 2064 end; 2065 end loop; 2066 2067 Free (S); 2068 end Force_Elab_Order; 2069 2070 ------------------------- 2071 -- Gather_Dependencies -- 2072 ------------------------- 2073 2074 procedure Gather_Dependencies is 2075 Withed_Unit : Unit_Id; 2076 2077 begin 2078 -- Loop through all units 2079 2080 for U in Units.First .. Units.Last loop 2081 Cur_Unit := U; 2082 2083 -- If this is not an interface to a stand-alone library and there is 2084 -- a body and a spec, then spec must be elaborated first. Note that 2085 -- the corresponding spec immediately follows the body. 2086 2087 if not Units.Table (U).SAL_Interface 2088 and then Units.Table (U).Utype = Is_Body 2089 then 2090 Build_Link (Corresponding_Spec (U), U, Spec_First); 2091 end if; 2092 2093 -- If this unit is not an interface to a stand-alone library, process 2094 -- WITH references for this unit ignoring interfaces to stand-alone 2095 -- libraries. 2096 2097 if not Units.Table (U).SAL_Interface then 2098 for W in Units.Table (U).First_With .. 2099 Units.Table (U).Last_With 2100 loop 2101 if Withs.Table (W).Sfile /= No_File 2102 and then (not Withs.Table (W).SAL_Interface) 2103 then 2104 -- Check for special case of withing a unit that does not 2105 -- exist any more. If the unit was completely missing we 2106 -- would already have detected this, but a nasty case arises 2107 -- when we have a subprogram body with no spec, and some 2108 -- obsolete unit with's a previous (now disappeared) spec. 2109 2110 if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then 2111 if Doing_New then 2112 Error_Msg_File_1 := Units.Table (U).Sfile; 2113 Error_Msg_Unit_1 := Withs.Table (W).Uname; 2114 Error_Msg ("{ depends on $ which no longer exists"); 2115 end if; 2116 2117 goto Next_With; 2118 end if; 2119 2120 Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname); 2121 2122 -- Pragma Elaborate_All case, for this we use the recursive 2123 -- Elab_All_Links procedure to establish the links. 2124 2125 -- Elab_New ignores Elaborate_All and Elab_All_Desirable, 2126 -- except for error messages. 2127 2128 if Withs.Table (W).Elaborate_All and then not Doing_New then 2129 2130 -- Reset flags used to stop multiple visits to a given 2131 -- node. 2132 2133 for Uref in UNR.First .. UNR.Last loop 2134 UNR.Table (Uref).Visited := False; 2135 end loop; 2136 2137 -- Now establish all the links we need 2138 2139 Elab_All_Links 2140 (Withed_Unit, U, Elab_All, 2141 Make_Elab_All_Entry 2142 (Withs.Table (W).Uname, No_Elab_All_Link)); 2143 2144 -- Elaborate_All_Desirable case, for this we establish the 2145 -- same links as above, but with a different reason. 2146 2147 elsif Withs.Table (W).Elab_All_Desirable 2148 and then not Doing_New 2149 then 2150 -- Reset flags used to stop multiple visits to a given 2151 -- node. 2152 2153 for Uref in UNR.First .. UNR.Last loop 2154 UNR.Table (Uref).Visited := False; 2155 end loop; 2156 2157 -- Now establish all the links we need 2158 2159 Elab_All_Links 2160 (Withed_Unit, U, Elab_All_Desirable, 2161 Make_Elab_All_Entry 2162 (Withs.Table (W).Uname, No_Elab_All_Link)); 2163 2164 -- Pragma Elaborate case. We must build a link for the 2165 -- withed unit itself, and also the corresponding body if 2166 -- there is one. 2167 2168 -- However, skip this processing if there is no ALI file for 2169 -- the WITH entry, because this means it is a generic (even 2170 -- when we fix the generics so that an ALI file is present, 2171 -- we probably still will have no ALI file for unchecked and 2172 -- other special cases). 2173 2174 elsif Withs.Table (W).Elaborate 2175 and then Withs.Table (W).Afile /= No_File 2176 then 2177 Build_Link (Withed_Unit, U, Withed); 2178 2179 if Units.Table (Withed_Unit).Utype = Is_Spec then 2180 Build_Link 2181 (Corresponding_Body (Withed_Unit), U, Elab); 2182 end if; 2183 2184 -- Elaborate_Desirable case, for this we establish the same 2185 -- links as above, but with a different reason. 2186 2187 elsif Withs.Table (W).Elab_Desirable then 2188 Build_Link (Withed_Unit, U, Withed); 2189 2190 if Units.Table (Withed_Unit).Utype = Is_Spec then 2191 Build_Link 2192 (Corresponding_Body (Withed_Unit), 2193 U, Elab_Desirable); 2194 end if; 2195 2196 -- A limited_with does not establish an elaboration 2197 -- dependence (that's the whole point). 2198 2199 elsif Withs.Table (W).Limited_With then 2200 null; 2201 2202 -- Case of normal WITH with no elaboration pragmas, just 2203 -- build the single link to the directly referenced unit 2204 2205 else 2206 Build_Link (Withed_Unit, U, Withed); 2207 end if; 2208 end if; 2209 2210 <<Next_With>> 2211 null; 2212 end loop; 2213 end if; 2214 end loop; 2215 2216 -- If -f<elab_order> switch was given, take into account dependences 2217 -- specified in the file <elab_order>. 2218 2219 if Force_Elab_Order_File /= null then 2220 Force_Elab_Order; 2221 end if; 2222 2223 -- Output elaboration dependencies if option is set 2224 2225 if Elab_Dependency_Output or Debug_Flag_E then 2226 if Doing_New then 2227 Write_Dependencies; 2228 end if; 2229 end if; 2230 end Gather_Dependencies; 2231 2232 ---------- 2233 -- Init -- 2234 ---------- 2235 2236 procedure Init is 2237 begin 2238 Num_Chosen := 0; 2239 Num_Left := Int (Units.Last - Units.First + 1); 2240 Succ.Init; 2241 Elab_All_Entries.Init; 2242 UNR.Init; 2243 2244 -- Initialize unit table for elaboration control 2245 2246 for U in Units.First .. Units.Last loop 2247 UNR.Append 2248 ((Successors => No_Successor, 2249 Num_Pred => 0, 2250 Nextnp => No_Unit_Id, 2251 Visited => False, 2252 Elab_Position => 0, 2253 SCC_Root => No_Unit_Id, 2254 Nodes => null, 2255 SCC_Num_Pred => 0, 2256 Validate_Seen => False)); 2257 end loop; 2258 end Init; 2259 2260 ------------------ 2261 -- Is_Body_Unit -- 2262 ------------------ 2263 2264 function Is_Body_Unit (U : Unit_Id) return Boolean is 2265 begin 2266 return 2267 Units.Table (U).Utype = Is_Body 2268 or else Units.Table (U).Utype = Is_Body_Only; 2269 end Is_Body_Unit; 2270 2271 ----------------------------- 2272 -- Is_Pure_Or_Preelab_Unit -- 2273 ----------------------------- 2274 2275 function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean is 2276 begin 2277 -- If we have a body with separate spec, test flags on the spec 2278 2279 if Units.Table (U).Utype = Is_Body then 2280 return 2281 Units.Table (Corresponding_Spec (U)).Preelab 2282 or else Units.Table (Corresponding_Spec (U)).Pure; 2283 2284 -- Otherwise we have a spec or body acting as spec, test flags on unit 2285 2286 else 2287 return Units.Table (U).Preelab or else Units.Table (U).Pure; 2288 end if; 2289 end Is_Pure_Or_Preelab_Unit; 2290 2291 --------------------- 2292 -- Is_Waiting_Body -- 2293 --------------------- 2294 2295 function Is_Waiting_Body (U : Unit_Id) return Boolean is 2296 begin 2297 return 2298 Units.Table (U).Utype = Is_Body 2299 and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0; 2300 end Is_Waiting_Body; 2301 2302 ------------------------- 2303 -- Make_Elab_All_Entry -- 2304 ------------------------- 2305 2306 function Make_Elab_All_Entry 2307 (Unam : Unit_Name_Type; 2308 Link : Elab_All_Id) return Elab_All_Id 2309 is 2310 begin 2311 Elab_All_Entries.Append ((Needed_By => Unam, Next_Elab => Link)); 2312 return Elab_All_Entries.Last; 2313 end Make_Elab_All_Entry; 2314 2315 ---------------- 2316 -- Unit_Id_Of -- 2317 ---------------- 2318 2319 function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is 2320 Info : constant Int := Get_Name_Table_Int (Uname); 2321 2322 begin 2323 pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); 2324 return Unit_Id (Info); 2325 end Unit_Id_Of; 2326 2327 -------------- 2328 -- Validate -- 2329 -------------- 2330 2331 procedure Validate (Order : Unit_Id_Array; Doing_New : Boolean) is 2332 Cur_SCC : Unit_Id := No_Unit_Id; 2333 OK : Boolean := True; 2334 Msg : String := "Old: "; 2335 2336 begin 2337 if Doing_New then 2338 Msg := "New: "; 2339 end if; 2340 2341 -- For each unit, assert that its successors are elaborated after it 2342 2343 for J in Order'Range loop 2344 declare 2345 U : constant Unit_Id := Order (J); 2346 S : Successor_Id := UNR.Table (U).Successors; 2347 2348 begin 2349 while S /= No_Successor loop 2350 if UNR.Table (Succ.Table (S).After).Elab_Position <= 2351 UNR.Table (U).Elab_Position 2352 then 2353 OK := False; 2354 Write_Line (Msg & " elab order failed"); 2355 end if; 2356 2357 S := Succ.Table (S).Next; 2358 end loop; 2359 end; 2360 end loop; 2361 2362 -- An SCC of size 2 units necessarily consists of a spec and the 2363 -- corresponding body. Assert that the body is elaborated immediately 2364 -- after the spec, with nothing in between. (We only have SCCs in the 2365 -- new algorithm.) 2366 2367 if Doing_New then 2368 for J in Order'Range loop 2369 declare 2370 U : constant Unit_Id := Order (J); 2371 2372 begin 2373 if Nodes (U)'Length = 2 then 2374 if Units.Table (U).Utype = Is_Spec then 2375 if Order (J + 1) /= Corresponding_Body (U) then 2376 OK := False; 2377 Write_Line (Msg & "Bad spec with SCC of size 2:"); 2378 Write_SCC (SCC (U)); 2379 end if; 2380 end if; 2381 2382 if Units.Table (U).Utype = Is_Body then 2383 if Order (J - 1) /= Corresponding_Spec (U) then 2384 OK := False; 2385 Write_Line (Msg & "Bad body with SCC of size 2:"); 2386 Write_SCC (SCC (U)); 2387 end if; 2388 end if; 2389 end if; 2390 end; 2391 end loop; 2392 2393 -- Assert that all units of an SCC are elaborated together, with no 2394 -- units from other SCCs in between. The above spec/body case is a 2395 -- special case of this general rule. 2396 2397 for J in Order'Range loop 2398 declare 2399 U : constant Unit_Id := Order (J); 2400 2401 begin 2402 if SCC (U) /= Cur_SCC then 2403 Cur_SCC := SCC (U); 2404 if UNR.Table (Cur_SCC).Validate_Seen then 2405 OK := False; 2406 Write_Line (Msg & "SCC not elaborated together:"); 2407 Write_SCC (Cur_SCC); 2408 end if; 2409 2410 UNR.Table (Cur_SCC).Validate_Seen := True; 2411 end if; 2412 end; 2413 end loop; 2414 end if; 2415 2416 pragma Assert (OK); 2417 end Validate; 2418 2419 ------------------- 2420 -- Write_Closure -- 2421 ------------------- 2422 2423 procedure Write_Closure (Order : Unit_Id_Array) is 2424 package Closure_Sources is new Table.Table 2425 (Table_Component_Type => File_Name_Type, 2426 Table_Index_Type => Natural, 2427 Table_Low_Bound => 1, 2428 Table_Initial => 10, 2429 Table_Increment => 100, 2430 Table_Name => "Gnatbind.Closure_Sources"); 2431 -- Table to record the sources in the closure, to avoid duplications 2432 2433 function Put_In_Sources (S : File_Name_Type) return Boolean; 2434 -- Check if S is already in table Sources and put in Sources if it is 2435 -- not. Return False if the source is already in Sources, and True if 2436 -- it is added. 2437 2438 -------------------- 2439 -- Put_In_Sources -- 2440 -------------------- 2441 2442 function Put_In_Sources (S : File_Name_Type) return Boolean is 2443 begin 2444 for J in 1 .. Closure_Sources.Last loop 2445 if Closure_Sources.Table (J) = S then 2446 return False; 2447 end if; 2448 end loop; 2449 2450 Closure_Sources.Append (S); 2451 return True; 2452 end Put_In_Sources; 2453 2454 -- Local variables 2455 2456 Source : File_Name_Type; 2457 2458 -- Start of processing for Write_Closure 2459 2460 begin 2461 Closure_Sources.Init; 2462 2463 if not Zero_Formatting then 2464 Write_Eol; 2465 Write_Line ("REFERENCED SOURCES"); 2466 end if; 2467 2468 for J in reverse Order'Range loop 2469 Source := Units.Table (Order (J)).Sfile; 2470 2471 -- Do not include same source more than once 2472 2473 if Put_In_Sources (Source) 2474 2475 -- Do not include run-time units unless -Ra switch set 2476 2477 and then (List_Closure_All 2478 or else not Is_Internal_File_Name (Source)) 2479 then 2480 if not Zero_Formatting then 2481 Write_Str (" "); 2482 end if; 2483 2484 Write_Line (Get_Name_String (Source)); 2485 end if; 2486 end loop; 2487 2488 -- Subunits do not appear in the elaboration table because they are 2489 -- subsumed by their parent units, but we need to list them for other 2490 -- tools. For now they are listed after other files, rather than right 2491 -- after their parent, since there is no easy link between the 2492 -- elaboration table and the ALIs table ??? As subunits may appear 2493 -- repeatedly in the list, if the parent unit appears in the context of 2494 -- several units in the closure, duplicates are suppressed. 2495 2496 for J in Sdep.First .. Sdep.Last loop 2497 Source := Sdep.Table (J).Sfile; 2498 2499 if Sdep.Table (J).Subunit_Name /= No_Name 2500 and then Put_In_Sources (Source) 2501 and then not Is_Internal_File_Name (Source) 2502 then 2503 if not Zero_Formatting then 2504 Write_Str (" "); 2505 end if; 2506 2507 Write_Line (Get_Name_String (Source)); 2508 end if; 2509 end loop; 2510 2511 if not Zero_Formatting then 2512 Write_Eol; 2513 end if; 2514 end Write_Closure; 2515 2516 ------------------------ 2517 -- Write_Dependencies -- 2518 ------------------------ 2519 2520 procedure Write_Dependencies is 2521 begin 2522 if not Zero_Formatting then 2523 Write_Eol; 2524 Write_Line (" ELABORATION ORDER DEPENDENCIES"); 2525 Write_Eol; 2526 end if; 2527 2528 Info_Prefix_Suppress := True; 2529 2530 for S in Succ_First .. Succ.Last loop 2531 Elab_Error_Msg (S); 2532 end loop; 2533 2534 Info_Prefix_Suppress := False; 2535 2536 if not Zero_Formatting then 2537 Write_Eol; 2538 end if; 2539 end Write_Dependencies; 2540 2541 -------------------------- 2542 -- Write_Elab_All_Chain -- 2543 -------------------------- 2544 2545 procedure Write_Elab_All_Chain (S : Successor_Id) is 2546 ST : constant Successor_Link := Succ.Table (S); 2547 After : constant Unit_Name_Type := Units.Table (ST.After).Uname; 2548 2549 L : Elab_All_Id; 2550 Nam : Unit_Name_Type; 2551 2552 First_Name : Boolean := True; 2553 2554 begin 2555 if ST.Reason in Elab_All .. Elab_All_Desirable then 2556 L := ST.Elab_All_Link; 2557 while L /= No_Elab_All_Link loop 2558 Nam := Elab_All_Entries.Table (L).Needed_By; 2559 Error_Msg_Unit_1 := Nam; 2560 Error_Msg_Output (" $", Info => True); 2561 2562 Get_Name_String (Nam); 2563 2564 if Name_Buffer (Name_Len) = 'b' then 2565 if First_Name then 2566 Error_Msg_Output 2567 (" must be elaborated along with its spec:", 2568 Info => True); 2569 2570 else 2571 Error_Msg_Output 2572 (" which must be elaborated along with its " 2573 & "spec:", 2574 Info => True); 2575 end if; 2576 2577 else 2578 if First_Name then 2579 Error_Msg_Output 2580 (" is withed by:", 2581 Info => True); 2582 2583 else 2584 Error_Msg_Output 2585 (" which is withed by:", 2586 Info => True); 2587 end if; 2588 end if; 2589 2590 First_Name := False; 2591 2592 L := Elab_All_Entries.Table (L).Next_Elab; 2593 end loop; 2594 2595 Error_Msg_Unit_1 := After; 2596 Error_Msg_Output (" $", Info => True); 2597 end if; 2598 end Write_Elab_All_Chain; 2599 2600 ---------------------- 2601 -- Write_Elab_Order -- 2602 ---------------------- 2603 2604 procedure Write_Elab_Order 2605 (Order : Unit_Id_Array; Title : String) 2606 is 2607 begin 2608 if Title /= "" then 2609 Write_Eol; 2610 Write_Line (Title); 2611 end if; 2612 2613 for J in Order'Range loop 2614 if not Units.Table (Order (J)).SAL_Interface then 2615 if not Zero_Formatting then 2616 Write_Str (" "); 2617 end if; 2618 2619 Write_Unit_Name (Units.Table (Order (J)).Uname); 2620 Write_Eol; 2621 end if; 2622 end loop; 2623 2624 if Title /= "" then 2625 Write_Eol; 2626 end if; 2627 end Write_Elab_Order; 2628 2629 -------------- 2630 -- Elab_New -- 2631 -------------- 2632 2633 package body Elab_New is 2634 2635 generic 2636 type Node is (<>); 2637 First_Node : Node; 2638 Last_Node : Node; 2639 type Node_Array is array (Pos range <>) of Node; 2640 with function Successors (N : Node) return Node_Array; 2641 with procedure Create_SCC (Root : Node; Nodes : Node_Array); 2642 2643 procedure Compute_Strongly_Connected_Components; 2644 -- Compute SCCs for a directed graph. The nodes in the graph are all 2645 -- values of type Node in the range First_Node .. Last_Node. 2646 -- Successors(N) returns the nodes pointed to by the edges emanating 2647 -- from N. Create_SCC is a callback that is called once for each SCC, 2648 -- passing in the Root node for that SCC (which is an arbitrary node in 2649 -- the SCC used as a representative of that SCC), and the set of Nodes 2650 -- in that SCC. 2651 -- 2652 -- This is generic, in case we want to use it elsewhere; then we could 2653 -- move this into a separate library unit. Unfortunately, it's not as 2654 -- generic as one might like. Ideally, we would have "type Node is 2655 -- private;", and pass in iterators to iterate over all nodes, and over 2656 -- the successors of a given node. However, that leads to using advanced 2657 -- features of Ada that are not allowed in the compiler and binder for 2658 -- bootstrapping reasons. It also leads to trampolines, which are not 2659 -- allowed in the compiler and binder. Restricting Node to be discrete 2660 -- allows us to iterate over all nodes with a 'for' loop, and allows us 2661 -- to attach temporary information to nodes by having an array indexed 2662 -- by Node. 2663 2664 procedure Compute_Unit_SCCs; 2665 -- Use the above generic procedure to compute the SCCs for the graph of 2666 -- units. Store in each Unit_Node_Record the SCC_Root and Nodes 2667 -- components. Also initialize the SCC_Num_Pred components. 2668 2669 procedure Find_Elab_All_Errors; 2670 -- Generate an error for illegal Elaborate_All pragmas (explicit or 2671 -- implicit). A pragma Elaborate_All (Y) on unit X is legal if and only 2672 -- if X and Y are in different SCCs. 2673 2674 ------------------------------------------- 2675 -- Compute_Strongly_Connected_Components -- 2676 ------------------------------------------- 2677 2678 procedure Compute_Strongly_Connected_Components is 2679 2680 -- This uses Tarjan's algorithm for finding SCCs. Comments here are 2681 -- intended to tell what it does, but if you want to know how it 2682 -- works, you have to look it up. Please do not modify this code 2683 -- without reading up on Tarjan's algorithm. 2684 2685 subtype Node_Index is Nat; 2686 No_Index : constant Node_Index := 0; 2687 2688 Num_Nodes : constant Nat := 2689 Node'Pos (Last_Node) - Node'Pos (First_Node) + 1; 2690 Stack : Node_Array (1 .. Num_Nodes); 2691 Top : Node_Index := 0; 2692 -- Stack of nodes, pushed when first visited. All nodes of an SCC are 2693 -- popped at once when the SCC is found. 2694 2695 subtype Valid_Node is Node range First_Node .. Last_Node; 2696 Node_Indices : array (Valid_Node) of Node_Index := 2697 (others => No_Index); 2698 -- Each node has an "index", which is the sequential number in the 2699 -- order in which they are visited in the recursive walk. No_Index 2700 -- means "not yet visited"; we want to avoid walking any node more 2701 -- than once. 2702 2703 Index : Node_Index := 1; 2704 -- Next value to be assigned to a node index 2705 2706 Low_Links : array (Valid_Node) of Node_Index; 2707 -- Low_Links (N) is the smallest index of nodes reachable from N 2708 2709 On_Stack : array (Valid_Node) of Boolean := (others => False); 2710 -- True if the node is currently on the stack 2711 2712 procedure Walk (N : Valid_Node); 2713 -- Recursive depth-first graph walk, with the node index used to 2714 -- avoid visiting a node more than once. 2715 2716 ---------- 2717 -- Walk -- 2718 ---------- 2719 2720 procedure Walk (N : Valid_Node) is 2721 Stack_Position_Of_N : constant Pos := Top + 1; 2722 S : constant Node_Array := Successors (N); 2723 2724 begin 2725 -- Assign the index and low link, increment Index for next call to 2726 -- Walk. 2727 2728 Node_Indices (N) := Index; 2729 Low_Links (N) := Index; 2730 Index := Index + 1; 2731 2732 -- Push it on the stack: 2733 2734 Top := Stack_Position_Of_N; 2735 Stack (Top) := N; 2736 On_Stack (N) := True; 2737 2738 -- Walk not-yet-visited subnodes, and update low link for visited 2739 -- ones as appropriate. 2740 2741 for J in S'Range loop 2742 if Node_Indices (S (J)) = No_Index then 2743 Walk (S (J)); 2744 Low_Links (N) := 2745 Node_Index'Min (Low_Links (N), Low_Links (S (J))); 2746 elsif On_Stack (S (J)) then 2747 Low_Links (N) := 2748 Node_Index'Min (Low_Links (N), Node_Indices (S (J))); 2749 end if; 2750 end loop; 2751 2752 -- If the index is (still) equal to the low link, we've found an 2753 -- SCC. Pop the whole SCC off the stack, and call Create_SCC. 2754 2755 if Low_Links (N) = Node_Indices (N) then 2756 declare 2757 SCC : Node_Array renames 2758 Stack (Stack_Position_Of_N .. Top); 2759 pragma Assert (SCC'Length >= 1); 2760 pragma Assert (SCC (SCC'First) = N); 2761 2762 begin 2763 for J in SCC'Range loop 2764 On_Stack (SCC (J)) := False; 2765 end loop; 2766 2767 Create_SCC (Root => N, Nodes => SCC); 2768 pragma Assert (Top - SCC'Length = Stack_Position_Of_N - 1); 2769 Top := Stack_Position_Of_N - 1; -- pop all 2770 end; 2771 end if; 2772 end Walk; 2773 2774 -- Start of processing for Compute_Strongly_Connected_Components 2775 2776 begin 2777 -- Walk all the nodes that have not yet been walked 2778 2779 for N in Valid_Node loop 2780 if Node_Indices (N) = No_Index then 2781 Walk (N); 2782 end if; 2783 end loop; 2784 end Compute_Strongly_Connected_Components; 2785 2786 ----------------------- 2787 -- Compute_Unit_SCCs -- 2788 ----------------------- 2789 2790 procedure Compute_Unit_SCCs is 2791 function Successors (U : Unit_Id) return Unit_Id_Array; 2792 -- Return all the units that must be elaborated after U. In addition, 2793 -- if U is a body, include the corresponding spec; this ensures that 2794 -- a spec/body pair are always in the same SCC. 2795 2796 procedure Create_SCC (Root : Unit_Id; Nodes : Unit_Id_Array); 2797 -- Set Nodes of the Root, and set SCC_Root of all the Nodes 2798 2799 procedure Init_SCC_Num_Pred (U : Unit_Id); 2800 -- Initialize the SCC_Num_Pred fields, so that the root of each SCC 2801 -- has a count of the number of successors of all the units in the 2802 -- SCC, but only for successors outside the SCC. 2803 2804 procedure Compute_SCCs is new Compute_Strongly_Connected_Components 2805 (Node => Unit_Id, 2806 First_Node => Units.First, 2807 Last_Node => Units.Last, 2808 Node_Array => Unit_Id_Array, 2809 Successors => Successors, 2810 Create_SCC => Create_SCC); 2811 2812 ---------------- 2813 -- Create_SCC -- 2814 ---------------- 2815 2816 procedure Create_SCC (Root : Unit_Id; Nodes : Unit_Id_Array) is 2817 begin 2818 if Debug_Flag_V then 2819 Write_Str ("Root = "); 2820 Write_Int (Int (Root)); 2821 Write_Str (" "); 2822 Write_Unit_Name (Units.Table (Root).Uname); 2823 Write_Str (" -- "); 2824 Write_Int (Nodes'Length); 2825 Write_Line (" units:"); 2826 2827 for J in Nodes'Range loop 2828 Write_Str (" "); 2829 Write_Int (Int (Nodes (J))); 2830 Write_Str (" "); 2831 Write_Unit_Name (Units.Table (Nodes (J)).Uname); 2832 Write_Eol; 2833 end loop; 2834 end if; 2835 2836 pragma Assert (Nodes (Nodes'First) = Root); 2837 pragma Assert (UNR.Table (Root).Nodes = null); 2838 UNR.Table (Root).Nodes := new Unit_Id_Array'(Nodes); 2839 2840 for J in Nodes'Range loop 2841 pragma Assert (SCC (Nodes (J)) = No_Unit_Id); 2842 UNR.Table (Nodes (J)).SCC_Root := Root; 2843 end loop; 2844 end Create_SCC; 2845 2846 ---------------- 2847 -- Successors -- 2848 ---------------- 2849 2850 function Successors (U : Unit_Id) return Unit_Id_Array is 2851 S : Successor_Id := UNR.Table (U).Successors; 2852 Tab : Unit_Id_Table; 2853 2854 begin 2855 -- Pretend that a spec is a successor of its body (even though it 2856 -- isn't), just so both get included. 2857 2858 if Units.Table (U).Utype = Is_Body then 2859 Append (Tab, Corresponding_Spec (U)); 2860 end if; 2861 2862 -- Now include the real successors 2863 2864 while S /= No_Successor loop 2865 pragma Assert (Succ.Table (S).Before = U); 2866 Append (Tab, Succ.Table (S).After); 2867 S := Succ.Table (S).Next; 2868 end loop; 2869 2870 declare 2871 Result : constant Unit_Id_Array := Tab.Table (1 .. Last (Tab)); 2872 2873 begin 2874 Free (Tab); 2875 return Result; 2876 end; 2877 end Successors; 2878 2879 ----------------------- 2880 -- Init_SCC_Num_Pred -- 2881 ----------------------- 2882 2883 procedure Init_SCC_Num_Pred (U : Unit_Id) is 2884 begin 2885 if UNR.Table (U).Visited then 2886 return; 2887 end if; 2888 2889 UNR.Table (U).Visited := True; 2890 2891 declare 2892 S : Successor_Id := UNR.Table (U).Successors; 2893 2894 begin 2895 while S /= No_Successor loop 2896 pragma Assert (Succ.Table (S).Before = U); 2897 Init_SCC_Num_Pred (Succ.Table (S).After); 2898 2899 if SCC (U) /= SCC (Succ.Table (S).After) then 2900 UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred := 2901 UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred + 1; 2902 end if; 2903 2904 S := Succ.Table (S).Next; 2905 end loop; 2906 end; 2907 end Init_SCC_Num_Pred; 2908 2909 -- Start of processing for Compute_Unit_SCCs 2910 2911 begin 2912 Compute_SCCs; 2913 2914 for Uref in UNR.First .. UNR.Last loop 2915 pragma Assert (not UNR.Table (Uref).Visited); 2916 null; 2917 end loop; 2918 2919 for Uref in UNR.First .. UNR.Last loop 2920 Init_SCC_Num_Pred (Uref); 2921 end loop; 2922 2923 -- Assert that SCC_Root of all units has been set to a valid unit, 2924 -- and that SCC_Num_Pred has not been modified in non-root units. 2925 2926 for Uref in UNR.First .. UNR.Last loop 2927 pragma Assert (UNR.Table (Uref).SCC_Root /= No_Unit_Id); 2928 pragma Assert (UNR.Table (Uref).SCC_Root in UNR.First .. UNR.Last); 2929 2930 if SCC (Uref) /= Uref then 2931 pragma Assert (UNR.Table (Uref).SCC_Num_Pred = 0); 2932 null; 2933 end if; 2934 end loop; 2935 end Compute_Unit_SCCs; 2936 2937 -------------------------- 2938 -- Find_Elab_All_Errors -- 2939 -------------------------- 2940 2941 procedure Find_Elab_All_Errors is 2942 Withed_Unit : Unit_Id; 2943 2944 begin 2945 for U in Units.First .. Units.Last loop 2946 2947 -- If this unit is not an interface to a stand-alone library, 2948 -- process WITH references for this unit ignoring interfaces to 2949 -- stand-alone libraries. 2950 2951 if not Units.Table (U).SAL_Interface then 2952 for W in Units.Table (U).First_With .. 2953 Units.Table (U).Last_With 2954 loop 2955 if Withs.Table (W).Sfile /= No_File 2956 and then (not Withs.Table (W).SAL_Interface) 2957 then 2958 -- Check for special case of withing a unit that does not 2959 -- exist any more. 2960 2961 if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then 2962 goto Next_With; 2963 end if; 2964 2965 Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname); 2966 2967 -- If it's Elaborate_All or Elab_All_Desirable, check 2968 -- that the withER and withEE are not in the same SCC. 2969 2970 if Withs.Table (W).Elaborate_All 2971 or else Withs.Table (W).Elab_All_Desirable 2972 then 2973 if SCC (U) = SCC (Withed_Unit) then 2974 Elab_Cycle_Found := True; -- ??? 2975 2976 -- We could probably give better error messages 2977 -- than Elab_Old here, but for now, to avoid 2978 -- disruption, we don't give any error here. 2979 -- Instead, we set the Elab_Cycle_Found flag above, 2980 -- and then run the Elab_Old algorithm to issue the 2981 -- error message. Ideally, we would like to print 2982 -- multiple errors rather than stopping after the 2983 -- first cycle. 2984 2985 if False then 2986 Error_Msg_Output 2987 ("illegal pragma Elaborate_All", 2988 Info => False); 2989 end if; 2990 end if; 2991 end if; 2992 end if; 2993 2994 <<Next_With>> 2995 null; 2996 end loop; 2997 end if; 2998 end loop; 2999 end Find_Elab_All_Errors; 3000 3001 --------------------- 3002 -- Find_Elab_Order -- 3003 --------------------- 3004 3005 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is 3006 Best_So_Far : Unit_Id; 3007 U : Unit_Id; 3008 3009 begin 3010 -- Gather dependencies and output them if option set 3011 3012 Gather_Dependencies; 3013 3014 Compute_Unit_SCCs; 3015 3016 -- Initialize the no-predecessor list 3017 3018 No_Pred := No_Unit_Id; 3019 for U in UNR.First .. UNR.Last loop 3020 if UNR.Table (U).Num_Pred = 0 then 3021 UNR.Table (U).Nextnp := No_Pred; 3022 No_Pred := U; 3023 end if; 3024 end loop; 3025 3026 -- OK, now we determine the elaboration order proper. All we do is to 3027 -- select the best choice from the no-predecessor list until all the 3028 -- nodes have been chosen. 3029 3030 Outer : loop 3031 if Debug_Flag_N then 3032 Write_Line ("Outer loop"); 3033 end if; 3034 3035 -- If there are no nodes with predecessors, then either we are 3036 -- done, as indicated by Num_Left being set to zero, or we have 3037 -- a circularity. In the latter case, diagnose the circularity, 3038 -- removing it from the graph and continue. 3039 -- ????But Diagnose_Elaboration_Problem always raises an 3040 -- exception, so the loop never goes around more than once. 3041 3042 Get_No_Pred : while No_Pred = No_Unit_Id loop 3043 exit Outer when Num_Left < 1; 3044 Diagnose_Elaboration_Problem (Elab_Order); 3045 end loop Get_No_Pred; 3046 3047 U := No_Pred; 3048 Best_So_Far := No_Unit_Id; 3049 3050 -- Loop to choose best entry in No_Pred list 3051 3052 No_Pred_Search : loop 3053 if Debug_Flag_N then 3054 Write_Str (" considering choice of "); 3055 Write_Unit_Name (Units.Table (U).Uname); 3056 Write_Eol; 3057 3058 if Units.Table (U).Elaborate_Body then 3059 Write_Str 3060 (" Elaborate_Body = True, Num_Pred for body = "); 3061 Write_Int 3062 (UNR.Table (Corresponding_Body (U)).Num_Pred); 3063 else 3064 Write_Str 3065 (" Elaborate_Body = False"); 3066 end if; 3067 3068 Write_Eol; 3069 end if; 3070 3071 -- Don't even consider units whose SCC is not ready. This 3072 -- ensures that all units of an SCC will be elaborated 3073 -- together, with no other units in between. 3074 3075 if SCC_Num_Pred (U) = 0 3076 and then Better_Choice (U, Best_So_Far) 3077 then 3078 if Debug_Flag_N then 3079 Write_Line (" tentatively chosen (best so far)"); 3080 end if; 3081 3082 Best_So_Far := U; 3083 else 3084 if Debug_Flag_N then 3085 Write_Line (" SCC not ready"); 3086 end if; 3087 end if; 3088 3089 U := UNR.Table (U).Nextnp; 3090 exit No_Pred_Search when U = No_Unit_Id; 3091 end loop No_Pred_Search; 3092 3093 -- If there are no units on the No_Pred list whose SCC is ready, 3094 -- there must be a cycle. Defer to Elab_Old to print an error 3095 -- message. 3096 3097 if Best_So_Far = No_Unit_Id then 3098 Elab_Cycle_Found := True; 3099 return; 3100 end if; 3101 3102 -- Choose the best candidate found 3103 3104 Choose (Elab_Order, Best_So_Far, " [Best_So_Far]"); 3105 3106 -- If it's a spec with a body, and the body is not yet chosen, 3107 -- choose the body if possible. The case where the body is 3108 -- already chosen is Elaborate_Body; the above call to Choose 3109 -- the spec will also Choose the body. 3110 3111 if Units.Table (Best_So_Far).Utype = Is_Spec 3112 and then UNR.Table 3113 (Corresponding_Body (Best_So_Far)).Elab_Position = 0 3114 then 3115 declare 3116 Choose_The_Body : constant Boolean := 3117 UNR.Table (Corresponding_Body 3118 (Best_So_Far)).Num_Pred = 0; 3119 3120 begin 3121 if Debug_Flag_B then 3122 Write_Str ("Can we choose the body?... "); 3123 3124 if Choose_The_Body then 3125 Write_Line ("Yes!"); 3126 else 3127 Write_Line ("No."); 3128 end if; 3129 end if; 3130 3131 if Choose_The_Body then 3132 Choose 3133 (Elab_Order => Elab_Order, 3134 Chosen => Corresponding_Body (Best_So_Far), 3135 Msg => " [body]"); 3136 end if; 3137 end; 3138 end if; 3139 3140 -- Finally, choose all the rest of the units in the same SCC as 3141 -- Best_So_Far. If it hasn't been chosen (Elab_Position = 0), and 3142 -- it's ready to be chosen (Num_Pred = 0), then we can choose it. 3143 3144 loop 3145 declare 3146 Chose_One_Or_More : Boolean := False; 3147 SCC : Unit_Id_Array renames Nodes (Best_So_Far).all; 3148 3149 begin 3150 for J in SCC'Range loop 3151 if UNR.Table (SCC (J)).Elab_Position = 0 3152 and then UNR.Table (SCC (J)).Num_Pred = 0 3153 then 3154 Chose_One_Or_More := True; 3155 Choose (Elab_Order, SCC (J), " [same SCC]"); 3156 end if; 3157 end loop; 3158 3159 exit when not Chose_One_Or_More; 3160 end; 3161 end loop; 3162 end loop Outer; 3163 3164 Find_Elab_All_Errors; 3165 end Find_Elab_Order; 3166 3167 ----------- 3168 -- Nodes -- 3169 ----------- 3170 3171 function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr is 3172 begin 3173 return UNR.Table (SCC (U)).Nodes; 3174 end Nodes; 3175 3176 --------- 3177 -- SCC -- 3178 --------- 3179 3180 function SCC (U : Unit_Id) return Unit_Id is 3181 begin 3182 return UNR.Table (U).SCC_Root; 3183 end SCC; 3184 3185 ------------------ 3186 -- SCC_Num_Pred -- 3187 ------------------ 3188 3189 function SCC_Num_Pred (U : Unit_Id) return Int is 3190 begin 3191 return UNR.Table (SCC (U)).SCC_Num_Pred; 3192 end SCC_Num_Pred; 3193 3194 --------------- 3195 -- Write_SCC -- 3196 --------------- 3197 3198 procedure Write_SCC (U : Unit_Id) is 3199 pragma Assert (SCC (U) = U); 3200 begin 3201 for J in Nodes (U)'Range loop 3202 Write_Int (UNR.Table (Nodes (U) (J)).Elab_Position); 3203 Write_Str (". "); 3204 Write_Unit_Name (Units.Table (Nodes (U) (J)).Uname); 3205 Write_Eol; 3206 end loop; 3207 3208 Write_Eol; 3209 end Write_SCC; 3210 3211 end Elab_New; 3212 3213 -------------- 3214 -- Elab_Old -- 3215 -------------- 3216 3217 package body Elab_Old is 3218 3219 --------------------- 3220 -- Find_Elab_Order -- 3221 --------------------- 3222 3223 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is 3224 Best_So_Far : Unit_Id; 3225 U : Unit_Id; 3226 3227 begin 3228 -- Gather dependencies and output them if option set 3229 3230 Gather_Dependencies; 3231 3232 -- Initialize the no-predecessor list 3233 3234 No_Pred := No_Unit_Id; 3235 for U in UNR.First .. UNR.Last loop 3236 if UNR.Table (U).Num_Pred = 0 then 3237 UNR.Table (U).Nextnp := No_Pred; 3238 No_Pred := U; 3239 end if; 3240 end loop; 3241 3242 -- OK, now we determine the elaboration order proper. All we do is to 3243 -- select the best choice from the no-predecessor list until all the 3244 -- nodes have been chosen. 3245 3246 Outer : loop 3247 3248 -- If there are no nodes with predecessors, then either we are 3249 -- done, as indicated by Num_Left being set to zero, or we have 3250 -- a circularity. In the latter case, diagnose the circularity, 3251 -- removing it from the graph and continue. 3252 -- ????But Diagnose_Elaboration_Problem always raises an 3253 -- exception, so the loop never goes around more than once. 3254 3255 Get_No_Pred : while No_Pred = No_Unit_Id loop 3256 exit Outer when Num_Left < 1; 3257 Diagnose_Elaboration_Problem (Elab_Order); 3258 end loop Get_No_Pred; 3259 3260 U := No_Pred; 3261 Best_So_Far := No_Unit_Id; 3262 3263 -- Loop to choose best entry in No_Pred list 3264 3265 No_Pred_Search : loop 3266 if Debug_Flag_N then 3267 Write_Str (" considering choice of "); 3268 Write_Unit_Name (Units.Table (U).Uname); 3269 Write_Eol; 3270 3271 if Units.Table (U).Elaborate_Body then 3272 Write_Str 3273 (" Elaborate_Body = True, Num_Pred for body = "); 3274 Write_Int 3275 (UNR.Table (Corresponding_Body (U)).Num_Pred); 3276 else 3277 Write_Str 3278 (" Elaborate_Body = False"); 3279 end if; 3280 3281 Write_Eol; 3282 end if; 3283 3284 -- This is a candididate to be considered for choice 3285 3286 if Better_Choice (U, Best_So_Far) then 3287 if Debug_Flag_N then 3288 Write_Line (" tentatively chosen (best so far)"); 3289 end if; 3290 3291 Best_So_Far := U; 3292 end if; 3293 3294 U := UNR.Table (U).Nextnp; 3295 exit No_Pred_Search when U = No_Unit_Id; 3296 end loop No_Pred_Search; 3297 3298 -- Choose the best candidate found 3299 3300 Choose (Elab_Order, Best_So_Far, " [Elab_Old Best_So_Far]"); 3301 end loop Outer; 3302 end Find_Elab_Order; 3303 3304 end Elab_Old; 3305 3306end Binde; 3307