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