1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- B I N D E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2003 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Binderr; use Binderr; 28with Butil; use Butil; 29with Debug; use Debug; 30with Fname; use Fname; 31with Lib; use Lib; 32with Namet; use Namet; 33with Opt; use Opt; 34with Output; use Output; 35 36package body Binde is 37 38 -- The following data structures are used to represent the graph that is 39 -- used to determine the elaboration order (using a topological sort). 40 41 -- The following structures are used to record successors. If A is a 42 -- successor of B in this table, it means that A must be elaborated 43 -- before B is elaborated. 44 45 type Successor_Id is new Nat; 46 -- Identification of single successor entry 47 48 No_Successor : constant Successor_Id := 0; 49 -- Used to indicate end of list of successors 50 51 type Elab_All_Id is new Nat; 52 -- Identification of Elab_All entry link 53 54 No_Elab_All_Link : constant Elab_All_Id := 0; 55 -- Used to indicate end of list 56 57 -- Succ_Reason indicates the reason for a particular elaboration link 58 59 type Succ_Reason is 60 (Withed, 61 -- After directly with's Before, so the spec of Before must be 62 -- elaborated before After is elaborated. 63 64 Elab, 65 -- After directly mentions Before in a pragma Elaborate, so the 66 -- body of Before must be elaborate before After is elaborated. 67 68 Elab_All, 69 -- After either mentions Before directly in a pragma Elaborate_All, 70 -- or mentions a third unit, X, which itself requires that Before be 71 -- elaborated before unit X is elaborated. The Elab_All_Link list 72 -- traces the dependencies in the latter case. 73 74 Elab_Desirable, 75 -- This is just like Elab_All, except that the elaborate all was not 76 -- explicitly present in the source, but rather was created by the 77 -- front end, which decided that it was "desirable". 78 79 Spec_First); 80 -- After is a body, and Before is the corresponding spec 81 82 -- Successor_Link contains the information for one link 83 84 type Successor_Link is record 85 Before : Unit_Id; 86 -- Predecessor unit 87 88 After : Unit_Id; 89 -- Successor unit 90 91 Next : Successor_Id; 92 -- Next successor on this list 93 94 Reason : Succ_Reason; 95 -- Reason for this link 96 97 Elab_Body : Boolean; 98 -- Set True if this link is needed for the special Elaborate_Body 99 -- processing described below. 100 101 Reason_Unit : Unit_Id; 102 -- For Reason = Elab, or Elab_All or Elab_Desirable, records the unit 103 -- containing the pragma leading to the link. 104 105 Elab_All_Link : Elab_All_Id; 106 -- If Reason = Elab_All or Elab_Desirable, then this points to the 107 -- first elment in a list of Elab_All entries that record the with 108 -- chain leading resulting in this particular dependency. 109 110 end record; 111 112 -- Note on handling of Elaborate_Body. Basically, if we have a pragma 113 -- Elaborate_Body in a unit, it means that the spec and body have to 114 -- be handled as a single entity from the point of view of determining 115 -- an elaboration order. What we do is to essentially remove the body 116 -- from consideration completely, and transfer all its links (other 117 -- than the spec link) to the spec. Then when then the spec gets chosen, 118 -- we choose the body right afterwards. We mark the links that get moved 119 -- from the body to the spec by setting their Elab_Body flag True, so 120 -- that we can understand what is going on! 121 122 Succ_First : constant := 1; 123 124 package Succ is new Table.Table ( 125 Table_Component_Type => Successor_Link, 126 Table_Index_Type => Successor_Id, 127 Table_Low_Bound => Succ_First, 128 Table_Initial => 500, 129 Table_Increment => 200, 130 Table_Name => "Succ"); 131 132 -- For the case of Elaborate_All, the following table is used to record 133 -- chains of with relationships that lead to the Elab_All link. These 134 -- are used solely for diagnostic purposes 135 136 type Elab_All_Entry is record 137 Needed_By : Unit_Name_Type; 138 -- Name of unit from which referencing unit was with'ed or otherwise 139 -- needed as a result of Elaborate_All or Elaborate_Desirable. 140 141 Next_Elab : Elab_All_Id; 142 -- Link to next entry on chain (No_Elab_All_Link marks end of list) 143 end record; 144 145 package Elab_All_Entries is new Table.Table ( 146 Table_Component_Type => Elab_All_Entry, 147 Table_Index_Type => Elab_All_Id, 148 Table_Low_Bound => 1, 149 Table_Initial => 2000, 150 Table_Increment => 200, 151 Table_Name => "Elab_All_Entries"); 152 153 -- A Unit_Node record is built for each active unit 154 155 type Unit_Node_Record is record 156 157 Successors : Successor_Id; 158 -- Pointer to list of links for successor nodes 159 160 Num_Pred : Int; 161 -- Number of predecessors for this unit. Normally non-negative, but 162 -- can go negative in the case of units chosen by the diagnose error 163 -- procedure (when cycles are being removed from the graph). 164 165 Nextnp : Unit_Id; 166 -- Forward pointer for list of units with no predecessors 167 168 Elab_Order : Nat; 169 -- Position in elaboration order (zero = not placed yet) 170 171 Visited : Boolean; 172 -- Used in computing transitive closure for elaborate all and 173 -- also in locating cycles and paths in the diagnose routines. 174 175 Elab_Position : Natural; 176 -- Initialized to zero. Set non-zero when a unit is chosen and 177 -- placed in the elaboration order. The value represents the 178 -- ordinal position in the elaboration order. 179 180 end record; 181 182 package UNR is new Table.Table ( 183 Table_Component_Type => Unit_Node_Record, 184 Table_Index_Type => Unit_Id, 185 Table_Low_Bound => First_Unit_Entry, 186 Table_Initial => 500, 187 Table_Increment => 200, 188 Table_Name => "UNR"); 189 190 No_Pred : Unit_Id; 191 -- Head of list of items with no predecessors 192 193 Num_Left : Int; 194 -- Number of entries not yet dealt with 195 196 Cur_Unit : Unit_Id; 197 -- Current unit, set by Gather_Dependencies, and picked up in Build_Link 198 -- to set the Reason_Unit field of the created dependency link. 199 200 Num_Chosen : Natural := 0; 201 -- Number of units chosen in the elaboration order so far 202 203 ----------------------- 204 -- Local Subprograms -- 205 ----------------------- 206 207 function Better_Choice (U1, U2 : Unit_Id) return Boolean; 208 -- U1 and U2 are both permitted candidates for selection as the next unit 209 -- to be elaborated. This function determines whether U1 is a better choice 210 -- than U2, i.e. should be elaborated in preference to U2, based on a set 211 -- of heuristics that establish a friendly and predictable order (see body 212 -- for details). The result is True if U1 is a better choice than U2, and 213 -- False if it is a worse choice, or there is no preference between them. 214 215 procedure Build_Link 216 (Before : Unit_Id; 217 After : Unit_Id; 218 R : Succ_Reason; 219 Ea_Id : Elab_All_Id := No_Elab_All_Link); 220 -- Establish a successor link, Before must be elaborated before After, 221 -- and the reason for the link is R. Ea_Id is the contents to be placed 222 -- in the Elab_All_Link of the entry. 223 224 procedure Choose (Chosen : Unit_Id); 225 -- Chosen is the next entry chosen in the elaboration order. This 226 -- procedure updates all data structures appropriately. 227 228 function Corresponding_Body (U : Unit_Id) return Unit_Id; 229 pragma Inline (Corresponding_Body); 230 -- Given a unit which is a spec for which there is a separate body, 231 -- return the unit id of the body. It is an error to call this routine 232 -- with a unit that is not a spec, or which does not have a separate body. 233 234 function Corresponding_Spec (U : Unit_Id) return Unit_Id; 235 pragma Inline (Corresponding_Spec); 236 -- Given a unit which is a body for which there is a separate spec, 237 -- return the unit id of the spec. It is an error to call this routine 238 -- with a unit that is not a body, or which does not have a separate spec. 239 240 procedure Diagnose_Elaboration_Problem; 241 -- Called when no elaboration order can be found. Outputs an appropriate 242 -- diagnosis of the problem, and then abandons the bind. 243 244 procedure Elab_All_Links 245 (Before : Unit_Id; 246 After : Unit_Id; 247 Reason : Succ_Reason; 248 Link : Elab_All_Id); 249 -- Used to compute the transitive closure of elaboration links for an 250 -- Elaborate_All pragma (Reason = Elab_All) or for an indication of 251 -- Elaborate_All_Desirable (Reason = Elab_Desirable). Unit After has 252 -- a pragma Elaborate_All or the front end has determined that a reference 253 -- probably requires Elaborate_All is required, and unit Before must be 254 -- previously elaborated. First a link is built making sure that unit 255 -- Before is elaborated before After, then a recursive call ensures that 256 -- we also build links for any units needed by Before (i.e. these units 257 -- must/should also be elaborated before After). Link is used to build 258 -- a chain of Elab_All_Entries to explain the reason for a link. The 259 -- value passed is the chain so far. 260 261 procedure Elab_Error_Msg (S : Successor_Id); 262 -- Given a successor link, outputs an error message of the form 263 -- "& must be elaborated before & ..." where ... is the reason. 264 265 procedure Gather_Dependencies; 266 -- Compute dependencies, building the Succ and UNR tables 267 268 function Make_Elab_Entry 269 (Unam : Unit_Name_Type; 270 Link : Elab_All_Id) 271 return Elab_All_Id; 272 -- Make an Elab_All_Entries table entry with the given Unam and Link. 273 274 function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id; 275 -- This function uses the Info field set in the names table to obtain 276 -- the unit Id of a unit, given its name id value. 277 278 function Worse_Choice (U1, U2 : Unit_Id) return Boolean; 279 -- This is like Better_Choice, and has the same interface, but returns 280 -- true if U1 is a worse choice than U2 in the sense of the -h (horrible 281 -- elaboration order) switch. We still have to obey Ada rules, so it is 282 -- not quite the direct inverse of Better_Choice. 283 284 procedure Write_Dependencies; 285 -- Write out dependencies (called only if appropriate option is set) 286 287 procedure Write_Elab_All_Chain (S : Successor_Id); 288 -- If the reason for the link S is Elaborate_All or Elaborate_Desirable, 289 -- then this routine will output the "needed by" explanation chain. 290 291 ------------------- 292 -- Better_Choice -- 293 ------------------- 294 295 function Better_Choice (U1, U2 : Unit_Id) return Boolean is 296 297 function Body_Unit (U : Unit_Id) return Boolean; 298 -- Determines if given unit is a body 299 300 function Waiting_Body (U : Unit_Id) return Boolean; 301 -- Determines if U is a waiting body, defined as a body which has 302 -- not been elaborated, but whose spec has been elaborated. 303 304 function Body_Unit (U : Unit_Id) return Boolean is 305 begin 306 return Units.Table (U).Utype = Is_Body 307 or else Units.Table (U).Utype = Is_Body_Only; 308 end Body_Unit; 309 310 function Waiting_Body (U : Unit_Id) return Boolean is 311 begin 312 return Units.Table (U).Utype = Is_Body 313 and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0; 314 end Waiting_Body; 315 316 -- Start of processing for Better_Choice 317 318 -- Note: the checks here are applied in sequence, and the ordering is 319 -- significant (i.e. the more important criteria are applied first). 320 321 begin 322 -- Prefer a waiting body to any other case 323 324 if Waiting_Body (U1) and not Waiting_Body (U2) then 325 return True; 326 327 elsif Waiting_Body (U2) and not Waiting_Body (U1) then 328 return False; 329 330 -- Prefer a predefined unit to a non-predefined unit 331 332 elsif Units.Table (U1).Predefined 333 and not Units.Table (U2).Predefined 334 then 335 return True; 336 337 elsif Units.Table (U2).Predefined 338 and not Units.Table (U1).Predefined 339 then 340 return False; 341 342 -- Prefer an internal unit to a non-internal unit 343 344 elsif Units.Table (U1).Internal 345 and not Units.Table (U2).Internal 346 then 347 return True; 348 349 elsif Units.Table (U2).Internal 350 and not Units.Table (U1).Internal 351 then 352 return False; 353 354 -- Prefer a body to a spec 355 356 elsif Body_Unit (U1) and not Body_Unit (U2) then 357 return True; 358 359 elsif Body_Unit (U2) and not Body_Unit (U1) then 360 return False; 361 362 -- If both are waiting bodies, then prefer the one whose spec is 363 -- more recently elaborated. Consider the following: 364 365 -- spec of A 366 -- spec of B 367 -- body of A or B? 368 369 -- The normal waiting body preference would have placed the body of 370 -- A before the spec of B if it could. Since it could not, there it 371 -- must be the case that A depends on B. It is therefore a good idea 372 -- to put the body of B first. 373 374 elsif Waiting_Body (U1) and then Waiting_Body (U2) then 375 return 376 UNR.Table (Corresponding_Spec (U1)).Elab_Position > 377 UNR.Table (Corresponding_Spec (U2)).Elab_Position; 378 379 -- Otherwise decide on the basis of alphabetical order 380 381 else 382 return Uname_Less (Units.Table (U1).Uname, Units.Table (U2).Uname); 383 end if; 384 end Better_Choice; 385 386 ---------------- 387 -- Build_Link -- 388 ---------------- 389 390 procedure Build_Link 391 (Before : Unit_Id; 392 After : Unit_Id; 393 R : Succ_Reason; 394 Ea_Id : Elab_All_Id := No_Elab_All_Link) 395 is 396 Cspec : Unit_Id; 397 398 begin 399 Succ.Increment_Last; 400 Succ.Table (Succ.Last).Before := Before; 401 Succ.Table (Succ.Last).Next := UNR.Table (Before).Successors; 402 UNR.Table (Before).Successors := Succ.Last; 403 Succ.Table (Succ.Last).Reason := R; 404 Succ.Table (Succ.Last).Reason_Unit := Cur_Unit; 405 Succ.Table (Succ.Last).Elab_All_Link := Ea_Id; 406 407 -- Deal with special Elab_Body case. If the After of this link is 408 -- a body whose spec has Elaborate_All set, and this is not the link 409 -- directly from the body to the spec, then we make the After of the 410 -- link reference its spec instead, marking the link appropriately. 411 412 if Units.Table (After).Utype = Is_Body then 413 Cspec := Corresponding_Spec (After); 414 415 if Units.Table (Cspec).Elaborate_Body 416 and then Cspec /= Before 417 then 418 Succ.Table (Succ.Last).After := Cspec; 419 Succ.Table (Succ.Last).Elab_Body := True; 420 UNR.Table (Cspec).Num_Pred := UNR.Table (Cspec).Num_Pred + 1; 421 return; 422 end if; 423 end if; 424 425 -- Fall through on normal case 426 427 Succ.Table (Succ.Last).After := After; 428 Succ.Table (Succ.Last).Elab_Body := False; 429 UNR.Table (After).Num_Pred := UNR.Table (After).Num_Pred + 1; 430 end Build_Link; 431 432 ------------ 433 -- Choose -- 434 ------------ 435 436 procedure Choose (Chosen : Unit_Id) is 437 S : Successor_Id; 438 U : Unit_Id; 439 440 begin 441 if Debug_Flag_C then 442 Write_Str ("Choosing Unit "); 443 Write_Unit_Name (Units.Table (Chosen).Uname); 444 Write_Eol; 445 end if; 446 447 -- Add to elaboration order. Note that units having no elaboration 448 -- code are not treated specially yet. The special casing of this 449 -- is in Bindgen, where Gen_Elab_Calls skips over them. Meanwhile 450 -- we need them here, because the object file list is also driven 451 -- by the contents of the Elab_Order table. 452 453 Elab_Order.Increment_Last; 454 Elab_Order.Table (Elab_Order.Last) := Chosen; 455 456 -- Remove from No_Pred list. This is a little inefficient and may 457 -- be we should doubly link the list, but it will do for now! 458 459 if No_Pred = Chosen then 460 No_Pred := UNR.Table (Chosen).Nextnp; 461 462 else 463 -- Note that we just ignore the situation where it does not 464 -- appear in the No_Pred list, this happens in calls from the 465 -- Diagnose_Elaboration_Problem routine, where cycles are being 466 -- removed arbitrarily from the graph. 467 468 U := No_Pred; 469 while U /= No_Unit_Id loop 470 if UNR.Table (U).Nextnp = Chosen then 471 UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp; 472 exit; 473 end if; 474 475 U := UNR.Table (U).Nextnp; 476 end loop; 477 end if; 478 479 -- For all successors, decrement the number of predecessors, and 480 -- if it becomes zero, then add to no predecessor list. 481 482 S := UNR.Table (Chosen).Successors; 483 484 while S /= No_Successor loop 485 U := Succ.Table (S).After; 486 UNR.Table (U).Num_Pred := UNR.Table (U).Num_Pred - 1; 487 488 if Debug_Flag_N then 489 Write_Str (" decrementing Num_Pred for unit "); 490 Write_Unit_Name (Units.Table (U).Uname); 491 Write_Str (" new value = "); 492 Write_Int (Int (UNR.Table (U).Num_Pred)); 493 Write_Eol; 494 end if; 495 496 if UNR.Table (U).Num_Pred = 0 then 497 UNR.Table (U).Nextnp := No_Pred; 498 No_Pred := U; 499 end if; 500 501 S := Succ.Table (S).Next; 502 end loop; 503 504 -- All done, adjust number of units left count and set elaboration pos 505 506 Num_Left := Num_Left - 1; 507 Num_Chosen := Num_Chosen + 1; 508 UNR.Table (Chosen).Elab_Position := Num_Chosen; 509 Units.Table (Chosen).Elab_Position := Num_Chosen; 510 511 -- If we just chose a spec with Elaborate_Body set, then we 512 -- must immediately elaborate the body, before any other units. 513 514 if Units.Table (Chosen).Elaborate_Body then 515 516 -- If the unit is a spec only, then there is no body. This is a bit 517 -- odd given that Elaborate_Body is here, but it is valid in an 518 -- RCI unit, where we only have the interface in the stub bind. 519 520 if Units.Table (Chosen).Utype = Is_Spec_Only 521 and then Units.Table (Chosen).RCI 522 then 523 null; 524 else 525 Choose (Corresponding_Body (Chosen)); 526 end if; 527 end if; 528 end Choose; 529 530 ------------------------ 531 -- Corresponding_Body -- 532 ------------------------ 533 534 -- Currently if the body and spec are separate, then they appear as 535 -- two separate units in the same ALI file, with the body appearing 536 -- first and the spec appearing second. 537 538 function Corresponding_Body (U : Unit_Id) return Unit_Id is 539 begin 540 pragma Assert (Units.Table (U).Utype = Is_Spec); 541 return U - 1; 542 end Corresponding_Body; 543 544 ------------------------ 545 -- Corresponding_Spec -- 546 ------------------------ 547 548 -- Currently if the body and spec are separate, then they appear as 549 -- two separate units in the same ALI file, with the body appearing 550 -- first and the spec appearing second. 551 552 function Corresponding_Spec (U : Unit_Id) return Unit_Id is 553 begin 554 pragma Assert (Units.Table (U).Utype = Is_Body); 555 return U + 1; 556 end Corresponding_Spec; 557 558 ---------------------------------- 559 -- Diagnose_Elaboration_Problem -- 560 ---------------------------------- 561 562 procedure Diagnose_Elaboration_Problem is 563 564 function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean; 565 -- Recursive routine used to find a path from node Ufrom to node Uto. 566 -- If a path exists, returns True and outputs an appropriate set of 567 -- error messages giving the path. Also calls Choose for each of the 568 -- nodes so that they get removed from the remaining set. There are 569 -- two cases of calls, either Ufrom = Uto for an attempt to find a 570 -- cycle, or Ufrom is a spec and Uto the corresponding body for the 571 -- case of an unsatisfiable Elaborate_Body pragma. ML is the minimum 572 -- acceptable length for a path. 573 574 --------------- 575 -- Find_Path -- 576 --------------- 577 578 function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean is 579 580 function Find_Link (U : Unit_Id; PL : Nat) return Boolean; 581 -- This is the inner recursive routine, it determines if a path 582 -- exists from U to Uto, and if so returns True and outputs the 583 -- appropriate set of error messages. PL is the path length 584 585 --------------- 586 -- Find_Link -- 587 --------------- 588 589 function Find_Link (U : Unit_Id; PL : Nat) return Boolean is 590 S : Successor_Id; 591 592 begin 593 -- Recursion ends if we are at terminating node and the path 594 -- is sufficiently long, generate error message and return True. 595 596 if U = Uto and then PL >= ML then 597 Choose (U); 598 return True; 599 600 -- All done if already visited, otherwise mark as visited 601 602 elsif UNR.Table (U).Visited then 603 return False; 604 605 -- Otherwise mark as visited and look at all successors 606 607 else 608 UNR.Table (U).Visited := True; 609 610 S := UNR.Table (U).Successors; 611 while S /= No_Successor loop 612 if Find_Link (Succ.Table (S).After, PL + 1) then 613 Elab_Error_Msg (S); 614 Choose (U); 615 return True; 616 end if; 617 618 S := Succ.Table (S).Next; 619 end loop; 620 621 -- Falling through means this does not lead to a path 622 623 return False; 624 end if; 625 end Find_Link; 626 627 -- Start of processing for Find_Path 628 629 begin 630 -- Initialize all non-chosen nodes to not visisted yet 631 632 for U in Units.First .. Units.Last loop 633 UNR.Table (U).Visited := UNR.Table (U).Elab_Position /= 0; 634 end loop; 635 636 -- Now try to find the path 637 638 return Find_Link (Ufrom, 0); 639 end Find_Path; 640 641 -- Start of processing for Diagnose_Elaboration_Error 642 643 begin 644 Set_Standard_Error; 645 646 -- Output state of things if debug flag N set 647 648 if Debug_Flag_N then 649 declare 650 NP : Int; 651 652 begin 653 Write_Eol; 654 Write_Eol; 655 Write_Str ("Diagnose_Elaboration_Problem called"); 656 Write_Eol; 657 Write_Str ("List of remaining unchosen units and predecessors"); 658 Write_Eol; 659 660 for U in Units.First .. Units.Last loop 661 if UNR.Table (U).Elab_Position = 0 then 662 NP := UNR.Table (U).Num_Pred; 663 Write_Eol; 664 Write_Str (" Unchosen unit: #"); 665 Write_Int (Int (U)); 666 Write_Str (" "); 667 Write_Unit_Name (Units.Table (U).Uname); 668 Write_Str (" (Num_Pred = "); 669 Write_Int (NP); 670 Write_Char (')'); 671 Write_Eol; 672 673 if NP = 0 then 674 if Units.Table (U).Elaborate_Body then 675 Write_Str 676 (" (not chosen because of Elaborate_Body)"); 677 Write_Eol; 678 else 679 Write_Str (" ****************** why not chosen?"); 680 Write_Eol; 681 end if; 682 end if; 683 684 -- Search links list to find unchosen predecessors 685 686 for S in Succ.First .. Succ.Last loop 687 declare 688 SL : Successor_Link renames Succ.Table (S); 689 690 begin 691 if SL.After = U 692 and then UNR.Table (SL.Before).Elab_Position = 0 693 then 694 Write_Str (" unchosen predecessor: #"); 695 Write_Int (Int (SL.Before)); 696 Write_Str (" "); 697 Write_Unit_Name (Units.Table (SL.Before).Uname); 698 Write_Eol; 699 NP := NP - 1; 700 end if; 701 end; 702 end loop; 703 704 if NP /= 0 then 705 Write_Str (" **************** Num_Pred value wrong!"); 706 Write_Eol; 707 end if; 708 end if; 709 end loop; 710 end; 711 end if; 712 713 -- Output the header for the error, and manually increment the 714 -- error count. We are using Error_Msg_Output rather than Error_Msg 715 -- here for two reasons: 716 717 -- This is really only one error, not one for each line 718 -- We want this output on standard output since it is voluminous 719 720 -- But we do need to deal with the error count manually in this case 721 722 Errors_Detected := Errors_Detected + 1; 723 Error_Msg_Output ("elaboration circularity detected", Info => False); 724 725 -- Try to find cycles starting with any of the remaining nodes that have 726 -- not yet been chosen. There must be at least one (there is some reason 727 -- we are being called!) 728 729 for U in Units.First .. Units.Last loop 730 if UNR.Table (U).Elab_Position = 0 then 731 if Find_Path (U, U, 1) then 732 raise Unrecoverable_Error; 733 end if; 734 end if; 735 end loop; 736 737 -- We should never get here, since we were called for some reason, 738 -- and we should have found and eliminated at least one bad path. 739 740 raise Program_Error; 741 742 end Diagnose_Elaboration_Problem; 743 744 -------------------- 745 -- Elab_All_Links -- 746 -------------------- 747 748 procedure Elab_All_Links 749 (Before : Unit_Id; 750 After : Unit_Id; 751 Reason : Succ_Reason; 752 Link : Elab_All_Id) 753 is 754 begin 755 if UNR.Table (Before).Visited then 756 return; 757 end if; 758 759 -- Build the direct link for Before 760 761 UNR.Table (Before).Visited := True; 762 Build_Link (Before, After, Reason, Link); 763 764 -- Process all units with'ed by Before recursively 765 766 for W in 767 Units.Table (Before).First_With .. Units.Table (Before).Last_With 768 loop 769 -- Skip if this with is an interface to a stand-alone library. 770 -- Skip also if no ALI file for this with, happens with certain 771 -- specialized generic files that do not get compiled. 772 773 if not Withs.Table (W).Interface 774 and then Withs.Table (W).Afile /= No_File 775 and then Generic_Separately_Compiled (Withs.Table (W).Sfile) 776 then 777 Elab_All_Links 778 (Unit_Id_Of (Withs.Table (W).Uname), 779 After, 780 Reason, 781 Make_Elab_Entry (Withs.Table (W).Uname, Link)); 782 end if; 783 end loop; 784 785 -- Process corresponding body, if there is one 786 787 if Units.Table (Before).Utype = Is_Spec then 788 Elab_All_Links 789 (Corresponding_Body (Before), 790 After, Reason, 791 Make_Elab_Entry 792 (Units.Table (Corresponding_Body (Before)).Uname, Link)); 793 end if; 794 end Elab_All_Links; 795 796 -------------------- 797 -- Elab_Error_Msg -- 798 -------------------- 799 800 procedure Elab_Error_Msg (S : Successor_Id) is 801 SL : Successor_Link renames Succ.Table (S); 802 803 begin 804 -- Nothing to do if internal unit involved and no -de flag 805 806 if not Debug_Flag_E 807 and then 808 (Is_Internal_File_Name (Units.Table (SL.Before).Sfile) 809 or else 810 Is_Internal_File_Name (Units.Table (SL.After).Sfile)) 811 then 812 return; 813 end if; 814 815 -- Here we want to generate output 816 817 Error_Msg_Name_1 := Units.Table (SL.Before).Uname; 818 819 if SL.Elab_Body then 820 Error_Msg_Name_2 := Units.Table (Corresponding_Body (SL.After)).Uname; 821 else 822 Error_Msg_Name_2 := Units.Table (SL.After).Uname; 823 end if; 824 825 Error_Msg_Output (" & must be elaborated before &", Info => True); 826 827 Error_Msg_Name_1 := Units.Table (SL.Reason_Unit).Uname; 828 829 case SL.Reason is 830 when Withed => 831 Error_Msg_Output 832 (" reason: with clause", 833 Info => True); 834 835 when Elab => 836 Error_Msg_Output 837 (" reason: pragma Elaborate in unit &", 838 Info => True); 839 840 when Elab_All => 841 Error_Msg_Output 842 (" reason: pragma Elaborate_All in unit &", 843 Info => True); 844 845 when Elab_Desirable => 846 Error_Msg_Output 847 (" reason: implicit Elaborate_All in unit &", 848 Info => True); 849 850 Error_Msg_Output 851 (" recompile & with -gnatwl for full details", 852 Info => True); 853 854 when Spec_First => 855 Error_Msg_Output 856 (" reason: spec always elaborated before body", 857 Info => True); 858 end case; 859 860 Write_Elab_All_Chain (S); 861 862 if SL.Elab_Body then 863 Error_Msg_Name_1 := Units.Table (SL.Before).Uname; 864 Error_Msg_Name_2 := Units.Table (SL.After).Uname; 865 Error_Msg_Output 866 (" & must therefore be elaborated before &", 867 True); 868 869 Error_Msg_Name_1 := Units.Table (SL.After).Uname; 870 Error_Msg_Output 871 (" (because & has a pragma Elaborate_Body)", 872 True); 873 end if; 874 875 Write_Eol; 876 end Elab_Error_Msg; 877 878 --------------------- 879 -- Find_Elab_Order -- 880 --------------------- 881 882 procedure Find_Elab_Order is 883 U : Unit_Id; 884 Best_So_Far : Unit_Id; 885 886 begin 887 Succ.Init; 888 Num_Left := Int (Units.Last - Units.First + 1); 889 890 -- Initialize unit table for elaboration control 891 892 for U in Units.First .. Units.Last loop 893 UNR.Increment_Last; 894 UNR.Table (UNR.Last).Successors := No_Successor; 895 UNR.Table (UNR.Last).Num_Pred := 0; 896 UNR.Table (UNR.Last).Nextnp := No_Unit_Id; 897 UNR.Table (UNR.Last).Elab_Order := 0; 898 UNR.Table (UNR.Last).Elab_Position := 0; 899 end loop; 900 901 -- Gather dependencies and output them if option set 902 903 Gather_Dependencies; 904 905 -- Output elaboration dependencies if option is set 906 907 if Elab_Dependency_Output or Debug_Flag_E then 908 Write_Dependencies; 909 end if; 910 911 -- Initialize the no predecessor list 912 913 No_Pred := No_Unit_Id; 914 915 for U in UNR.First .. UNR.Last loop 916 if UNR.Table (U).Num_Pred = 0 then 917 UNR.Table (U).Nextnp := No_Pred; 918 No_Pred := U; 919 end if; 920 end loop; 921 922 -- OK, now we determine the elaboration order proper. All we do is to 923 -- select the best choice from the no predecessor list until all the 924 -- nodes have been chosen. 925 926 Outer : loop 927 -- If there are no nodes with predecessors, then either we are 928 -- done, as indicated by Num_Left being set to zero, or we have 929 -- a circularity. In the latter case, diagnose the circularity, 930 -- removing it from the graph and continue 931 932 Get_No_Pred : while No_Pred = No_Unit_Id loop 933 exit Outer when Num_Left < 1; 934 Diagnose_Elaboration_Problem; 935 end loop Get_No_Pred; 936 937 U := No_Pred; 938 Best_So_Far := No_Unit_Id; 939 940 -- Loop to choose best entry in No_Pred list 941 942 No_Pred_Search : loop 943 if Debug_Flag_N then 944 Write_Str (" considering choice of "); 945 Write_Unit_Name (Units.Table (U).Uname); 946 Write_Eol; 947 948 if Units.Table (U).Elaborate_Body then 949 Write_Str 950 (" Elaborate_Body = True, Num_Pred for body = "); 951 Write_Int 952 (Int (UNR.Table (Corresponding_Body (U)).Num_Pred)); 953 else 954 Write_Str 955 (" Elaborate_Body = False"); 956 end if; 957 958 Write_Eol; 959 end if; 960 961 -- This is a candididate to be considered for choice 962 963 if Best_So_Far = No_Unit_Id 964 or else ((not Pessimistic_Elab_Order) 965 and then Better_Choice (U, Best_So_Far)) 966 or else (Pessimistic_Elab_Order 967 and then Worse_Choice (U, Best_So_Far)) 968 then 969 if Debug_Flag_N then 970 Write_Str (" tentatively chosen (best so far)"); 971 Write_Eol; 972 end if; 973 974 Best_So_Far := U; 975 end if; 976 977 U := UNR.Table (U).Nextnp; 978 exit No_Pred_Search when U = No_Unit_Id; 979 end loop No_Pred_Search; 980 981 -- If no candididate chosen, it means that no unit has No_Pred = 0, 982 -- but there are units left, hence we have a circular dependency, 983 -- which we will get Diagnose_Elaboration_Problem to diagnose it. 984 985 if Best_So_Far = No_Unit_Id then 986 Diagnose_Elaboration_Problem; 987 988 -- Otherwise choose the best candidate found 989 990 else 991 Choose (Best_So_Far); 992 end if; 993 end loop Outer; 994 995 end Find_Elab_Order; 996 997 ------------------------- 998 -- Gather_Dependencies -- 999 ------------------------- 1000 1001 procedure Gather_Dependencies is 1002 Withed_Unit : Unit_Id; 1003 1004 begin 1005 -- Loop through all units 1006 1007 for U in Units.First .. Units.Last loop 1008 Cur_Unit := U; 1009 1010 -- If this is not an interface to a stand-alone library and 1011 -- there is a body and a spec, then spec must be elaborated first 1012 -- Note that the corresponding spec immediately follows the body 1013 1014 if not Units.Table (U).Interface 1015 and then Units.Table (U).Utype = Is_Body 1016 then 1017 Build_Link (Corresponding_Spec (U), U, Spec_First); 1018 end if; 1019 1020 -- If this unit is not an interface to a stand-alone library, 1021 -- process WITH references for this unit ignoring generic units and 1022 -- interfaces to stand-alone libraries. 1023 1024 if not Units.Table (U).Interface then 1025 for 1026 W in Units.Table (U).First_With .. Units.Table (U).Last_With 1027 loop 1028 if Withs.Table (W).Sfile /= No_File 1029 and then (not Withs.Table (W).Interface) 1030 then 1031 -- Check for special case of withing a unit that does not 1032 -- exist any more. If the unit was completely missing we 1033 -- would already have detected this, but a nasty case arises 1034 -- when we have a subprogram body with no spec, and some 1035 -- obsolete unit with's a previous (now disappeared) spec. 1036 1037 if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then 1038 Error_Msg_Name_1 := Units.Table (U).Sfile; 1039 Error_Msg_Name_2 := Withs.Table (W).Uname; 1040 Error_Msg ("% depends on & which no longer exists"); 1041 goto Next_With; 1042 end if; 1043 1044 Withed_Unit := 1045 Unit_Id (Unit_Id_Of (Withs.Table (W).Uname)); 1046 1047 -- Pragma Elaborate_All case, for this we use the recursive 1048 -- Elab_All_Links procedure to establish the links. 1049 1050 if Withs.Table (W).Elaborate_All then 1051 1052 -- Reset flags used to stop multiple visits to a given 1053 -- node. 1054 1055 for Uref in UNR.First .. UNR.Last loop 1056 UNR.Table (Uref).Visited := False; 1057 end loop; 1058 1059 -- Now establish all the links we need 1060 1061 Elab_All_Links 1062 (Withed_Unit, U, Elab_All, 1063 Make_Elab_Entry 1064 (Withs.Table (W).Uname, No_Elab_All_Link)); 1065 1066 -- Elaborate_All_Desirable case, for this we establish 1067 -- the same links as above, but with a different reason. 1068 1069 elsif Withs.Table (W).Elab_All_Desirable then 1070 1071 -- Reset flags used to stop multiple visits to a given 1072 -- node. 1073 1074 for Uref in UNR.First .. UNR.Last loop 1075 UNR.Table (Uref).Visited := False; 1076 end loop; 1077 1078 -- Now establish all the links we need 1079 1080 Elab_All_Links 1081 (Withed_Unit, U, Elab_Desirable, 1082 Make_Elab_Entry 1083 (Withs.Table (W).Uname, No_Elab_All_Link)); 1084 1085 -- Pragma Elaborate case. We must build a link for the 1086 -- withed unit itself, and also the corresponding body 1087 -- if there is one. 1088 1089 -- However, skip this processing if there is no ALI file 1090 -- for the WITH entry, because this means it is a 1091 -- generic (even when we fix the generics so that an ALI 1092 -- file is present, we probably still will have no ALI 1093 -- file for unchecked and other special cases). 1094 1095 elsif Withs.Table (W).Elaborate 1096 and then Withs.Table (W).Afile /= No_File 1097 then 1098 Build_Link (Withed_Unit, U, Withed); 1099 1100 if Units.Table (Withed_Unit).Utype = Is_Spec then 1101 Build_Link 1102 (Corresponding_Body (Withed_Unit), U, Elab); 1103 end if; 1104 1105 -- Case of normal WITH with no elaboration pragmas, just 1106 -- build the single link to the directly referenced unit 1107 1108 else 1109 Build_Link (Withed_Unit, U, Withed); 1110 end if; 1111 end if; 1112 1113 <<Next_With>> 1114 null; 1115 end loop; 1116 end if; 1117 end loop; 1118 end Gather_Dependencies; 1119 1120 --------------------- 1121 -- Make_Elab_Entry -- 1122 --------------------- 1123 1124 function Make_Elab_Entry 1125 (Unam : Unit_Name_Type; 1126 Link : Elab_All_Id) 1127 return Elab_All_Id 1128 is 1129 begin 1130 Elab_All_Entries.Increment_Last; 1131 Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam; 1132 Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link; 1133 return Elab_All_Entries.Last; 1134 end Make_Elab_Entry; 1135 1136 ---------------- 1137 -- Unit_Id_Of -- 1138 ---------------- 1139 1140 function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is 1141 Info : constant Int := Get_Name_Table_Info (Uname); 1142 1143 begin 1144 pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); 1145 return Unit_Id (Info); 1146 end Unit_Id_Of; 1147 1148 ------------------ 1149 -- Worse_Choice -- 1150 ------------------ 1151 1152 function Worse_Choice (U1, U2 : Unit_Id) return Boolean is 1153 1154 function Body_Unit (U : Unit_Id) return Boolean; 1155 -- Determines if given unit is a body 1156 1157 function Waiting_Body (U : Unit_Id) return Boolean; 1158 -- Determines if U is a waiting body, defined as a body which has 1159 -- not been elaborated, but whose spec has been elaborated. 1160 1161 function Body_Unit (U : Unit_Id) return Boolean is 1162 begin 1163 return Units.Table (U).Utype = Is_Body 1164 or else Units.Table (U).Utype = Is_Body_Only; 1165 end Body_Unit; 1166 1167 function Waiting_Body (U : Unit_Id) return Boolean is 1168 begin 1169 return Units.Table (U).Utype = Is_Body and then 1170 UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0; 1171 end Waiting_Body; 1172 1173 -- Start of processing for Worse_Choice 1174 1175 -- Note: the checks here are applied in sequence, and the ordering is 1176 -- significant (i.e. the more important criteria are applied first). 1177 1178 begin 1179 -- If either unit is internal, then use Better_Choice, since the 1180 -- language requires that predefined units not mess up in the choice 1181 -- of elaboration order, and for internal units, any problems are 1182 -- ours and not the programmers. 1183 1184 if Units.Table (U1).Internal or else Units.Table (U2).Internal then 1185 return Better_Choice (U1, U2); 1186 1187 -- Prefer anything else to a waiting body (!) 1188 1189 elsif Waiting_Body (U1) and not Waiting_Body (U2) then 1190 return False; 1191 1192 elsif Waiting_Body (U2) and not Waiting_Body (U1) then 1193 return True; 1194 1195 -- Prefer a spec to a body (!) 1196 1197 elsif Body_Unit (U1) and not Body_Unit (U2) then 1198 return False; 1199 1200 elsif Body_Unit (U2) and not Body_Unit (U1) then 1201 return True; 1202 1203 -- If both are waiting bodies, then prefer the one whose spec is 1204 -- less recently elaborated. Consider the following: 1205 1206 -- spec of A 1207 -- spec of B 1208 -- body of A or B? 1209 1210 -- The normal waiting body preference would have placed the body of 1211 -- A before the spec of B if it could. Since it could not, there it 1212 -- must be the case that A depends on B. It is therefore a good idea 1213 -- to put the body of B last so that if there is an elaboration order 1214 -- problem, we will find it (that's what horrible order is about) 1215 1216 elsif Waiting_Body (U1) and then Waiting_Body (U2) then 1217 return 1218 UNR.Table (Corresponding_Spec (U1)).Elab_Position < 1219 UNR.Table (Corresponding_Spec (U2)).Elab_Position; 1220 1221 -- Otherwise decide on the basis of alphabetical order. We do not try 1222 -- to reverse the usual choice here, since it can cause cancelling 1223 -- errors with the other inversions. 1224 1225 else 1226 return Uname_Less (Units.Table (U1).Uname, Units.Table (U2).Uname); 1227 end if; 1228 end Worse_Choice; 1229 1230 ------------------------ 1231 -- Write_Dependencies -- 1232 ------------------------ 1233 1234 procedure Write_Dependencies is 1235 begin 1236 Write_Eol; 1237 Write_Str 1238 (" ELABORATION ORDER DEPENDENCIES"); 1239 Write_Eol; 1240 Write_Eol; 1241 1242 Info_Prefix_Suppress := True; 1243 1244 for S in Succ_First .. Succ.Last loop 1245 Elab_Error_Msg (S); 1246 end loop; 1247 1248 Info_Prefix_Suppress := False; 1249 Write_Eol; 1250 end Write_Dependencies; 1251 1252 -------------------------- 1253 -- Write_Elab_All_Chain -- 1254 -------------------------- 1255 1256 procedure Write_Elab_All_Chain (S : Successor_Id) is 1257 ST : constant Successor_Link := Succ.Table (S); 1258 After : constant Unit_Name_Type := Units.Table (ST.After).Uname; 1259 1260 L : Elab_All_Id; 1261 Nam : Unit_Name_Type; 1262 1263 First_Name : Boolean := True; 1264 1265 begin 1266 if ST.Reason in Elab_All .. Elab_Desirable then 1267 L := ST.Elab_All_Link; 1268 while L /= No_Elab_All_Link loop 1269 Nam := Elab_All_Entries.Table (L).Needed_By; 1270 Error_Msg_Name_1 := Nam; 1271 Error_Msg_Output (" &", Info => True); 1272 1273 Get_Name_String (Nam); 1274 1275 if Name_Buffer (Name_Len) = 'b' then 1276 if First_Name then 1277 Error_Msg_Output 1278 (" must be elaborated along with its spec:", 1279 Info => True); 1280 1281 else 1282 Error_Msg_Output 1283 (" which must be elaborated " & 1284 "along with its spec:", 1285 Info => True); 1286 end if; 1287 1288 else 1289 if First_Name then 1290 Error_Msg_Output 1291 (" is withed by:", 1292 Info => True); 1293 1294 else 1295 Error_Msg_Output 1296 (" which is withed by:", 1297 Info => True); 1298 end if; 1299 end if; 1300 1301 First_Name := False; 1302 1303 L := Elab_All_Entries.Table (L).Next_Elab; 1304 end loop; 1305 1306 Error_Msg_Name_1 := After; 1307 Error_Msg_Output (" &", Info => True); 1308 end if; 1309 end Write_Elab_All_Chain; 1310 1311end Binde; 1312