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