1------------------------------------------------------------------------------ 2-- -- 3-- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- 4-- -- 5-- A 4 G . C O N T T . D P -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1995-2014, Free Software Foundation, Inc. -- 10-- -- 11-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it -- 12-- under terms of the GNU General Public License as published by the Free -- 13-- Software Foundation; either version 3, or (at your option) any later -- 14-- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- 15-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- 16-- CHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- -- 19-- -- 20-- -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- 28-- Software Engineering Laboratory of the Swiss Federal Institute of -- 29-- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- 30-- Scientific Research Computer Center of Moscow State University (SRCC -- 31-- MSU), Russia, with funding partially provided by grants from the Swiss -- 32-- National Science Foundation and the Swiss Academy of Engineering -- 33-- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- 34-- (http://www.adacore.com). -- 35-- -- 36------------------------------------------------------------------------------ 37 38pragma Ada_2005; 39 40with Ada.Containers.Ordered_Sets; 41with Ada.Unchecked_Deallocation; 42 43with Asis.Set_Get; use Asis.Set_Get; 44 45with A4G.Contt.UT; use A4G.Contt.UT; 46with A4G.Get_Unit; use A4G.Get_Unit; 47 48with Atree; use Atree; 49with Nlists; use Nlists; 50with Namet; use Namet; 51with Sinfo; use Sinfo; 52with Lib; use Lib; 53 54package body A4G.Contt.Dp is 55 56 ----------------------- 57 -- Local Subprograms -- 58 ----------------------- 59 60 function Get_First_Stub (Body_Node : Node_Id) return Node_Id; 61 function Get_Next_Stub (Stub_Node : Node_Id) return Node_Id; 62 -- these two functions implement the iterator through the body stubs 63 -- contained in the given compilation unit. The iterator should 64 -- be started from calling Get_First_Stub for the node pointed to 65 -- the body (that is, for the node of ..._Body kind). The Empty node 66 -- is returned if there is no first/next body stub node 67 68 procedure Set_All_Unit_Dependencies (U : Unit_Id); 69 -- Computes the full lists of supporters and dependents of U in the current 70 -- Context from the list of direct supporters of U and sets these lists as 71 -- values of Supporters and Dependents lists in the Unit Table 72 73 procedure Add_Unit_Supporters (U : Unit_Id; L : in out Elist_Id); 74 -- Add all the supporters of U, excluding U itself to L. This procedure 75 -- traverses all the transitive semantic dependencies. 76 77 procedure Fix_Direct_Supporters (Unit : Unit_Id); 78 -- This procedure adds missed direct dependencies to the unit. It is 79 -- supposed that before the call the list of direct supporters contains 80 -- only units extracted from the unit context clause. So, if U is a body, 81 -- this procedure adds the spec to the list of direct supporters, if it is 82 -- a subunit - the parent body is added, if it is a child unit - the 83 -- parent spec is added etc. The procedure adds these supporters in a 84 -- transitive manner - that is, in case of a subunit, it adds the parent 85 -- body, its spec (if any), its parent (if any) etc. 86 -- This function supposes that Current Context is correctly set before 87 -- the call. 88 89 function In_List 90 (U : Unit_Id; 91 L : Unit_Id_List; 92 Up_To : Natural) 93 return Boolean; 94 -- Checks if U is a member of the first Up_To components of L. (If 95 -- Up_To is 0, False is returned 96 97 procedure CU_To_Unit_Id_List 98 (CU_List : Compilation_Unit_List; 99 Result_Unit_Id_List : in out Unit_Id_List; 100 Result_List_Len : out Natural); 101 -- Converts the ASIS Compilation Unit list into the list of Unit Ids and 102 -- places this list into Result_Unit_Id_List. (Probably, we should replace 103 -- this routine with a function...) 104 -- For each ASIS Compilation Unit from CU_List the Result_Unit_Id_List 105 -- contains exactly one Id for the corresponding unit. Result_List_Len is 106 -- set to represent the index of the last Unit Id in Result_List_Len (0 107 -- in case if Result_List_Len is empty). This routine expects that 108 -- Result_Unit_Id_List'Length >= CU_List'Length 109 110 -------------------------------------- 111 -- Dynamic Unit_Id list abstraction -- 112 -------------------------------------- 113 -- All the subprograms implementing Unit_Id list abstraction do not 114 -- reset Context 115 116 -- Is this package body the right place for defining this abstraction? 117 -- May be, we should move it into A4G.A_Types??? 118 119 type Unit_Id_List_Access is access Unit_Id_List; 120 Tmp_Unit_Id_List_Access : Unit_Id_List_Access; 121 122 procedure Free is new Ada.Unchecked_Deallocation 123 (Unit_Id_List, Unit_Id_List_Access); 124 125 function In_Unit_Id_List 126 (U : Unit_Id; 127 L : Unit_Id_List_Access) 128 return Boolean; 129 -- Checks if U is a member of L. 130 131 procedure Append_Unit_To_List 132 (U : Unit_Id; 133 L : in out Unit_Id_List_Access); 134 -- (Unconditionally) appends U to L. 135 136 procedure Add_To_Unit_Id_List 137 (U : Unit_Id; 138 L : in out Unit_Id_List_Access); 139 -- If not In_Unit_Id_List (U, L), U is appended to L (if L is null, 140 -- new Unit_Id_List value is created) 141 142 procedure Reorder_Sem_Dependencies (Units : Unit_Id_List_Access); 143 -- This procedure takes the unit list with is supposed to be the result of 144 -- one of the Set_All_<Relation> functions above (that is, its parameter 145 -- is not supposed to be null and it contains only existing units). It 146 -- reorders it in the way required by 147 -- Asis.Compilation_Units.Relations.Semantic_Dependence_Order - that is, 148 -- with no forward semantic dependencies. 149 150 ------------------- 151 -- Add_To_Parent -- 152 ------------------- 153 154 procedure Add_To_Parent (C : Context_Id; U : Unit_Id) is 155 Parent_Id : Unit_Id; 156 Unit_Kind : constant Unit_Kinds := Kind (C, U); 157 begin 158 159 if U = Standard_Id then 160 return; 161 end if; 162 163 Reset_Context (C); -- ??? 164 165 Get_Name_String (U, Norm_Ada_Name); 166 167 if Not_Root then 168 Form_Parent_Name; 169 170 if Unit_Kind in A_Subunit then 171 A_Name_Buffer (A_Name_Len) := 'b'; 172 end if; 173 174 Parent_Id := Name_Find (C); 175 -- Parent_Id cannot be Nil_Unit here 176 177 Append_Elmt 178 (Unit => U, 179 To => Unit_Table.Table (Parent_Id).Subunits_Or_Childs); 180 else 181 Append_Elmt 182 (Unit => U, 183 To => Unit_Table.Table (Standard_Id).Subunits_Or_Childs); 184 end if; 185 186 end Add_To_Parent; 187 188 ------------------------- 189 -- Add_Unit_Supporters -- 190 ------------------------- 191 192 procedure Add_Unit_Supporters (U : Unit_Id; L : in out Elist_Id) is 193 Supporters : Elist_Id renames Unit_Table.Table (U).Supporters; 194 Direct_Supporters : Elist_Id renames 195 Unit_Table.Table (U).Direct_Supporters; 196 197 Next_Support_Elmt : Elmt_Id; 198 Next_Support_Unit : Unit_Id; 199 200 begin 201 202 if Is_Empty_Elmt_List (Direct_Supporters) then 203 -- end of the recursion 204 return; 205 206 elsif not Is_Empty_Elmt_List (Supporters) then 207 -- no need to traverse indirect dependencies 208 209 Next_Support_Elmt := First_Elmt (Supporters); 210 211 while Present (Next_Support_Elmt) loop 212 Next_Support_Unit := Unit (Next_Support_Elmt); 213 214 Add_To_Elmt_List 215 (Unit => Next_Support_Unit, 216 List => L); 217 218 Next_Support_Elmt := Next_Elmt (Next_Support_Elmt); 219 220 end loop; 221 222 else 223 -- And here we have to traverse the recursive dependencies: 224 225 Next_Support_Elmt := First_Elmt (Direct_Supporters); 226 227 while Present (Next_Support_Elmt) loop 228 Next_Support_Unit := Unit (Next_Support_Elmt); 229 230 -- The old code currently commented out caused a huge delay 231 -- when opening one tree context (8326-002). We will keep it 232 -- till the new code is tested for queries from 233 -- Asis.Compilation_Units.Relations 234 235 -- ???Old code start 236 237 -- Here we can not be sure, that if Next_Support_Unit already 238 -- is in the list, all its supporters also are in the list 239 -- Add_To_Elmt_List 240 -- (Unit => Next_Support_Unit, 241 -- List => L); 242 243 -- Add_Unit_Supporters (Next_Support_Unit, L); 244 245 -- ???Old code end 246 247 -- ???New code start 248 if not In_Elmt_List (Next_Support_Unit, L) then 249 Append_Elmt 250 (Unit => Next_Support_Unit, 251 To => L); 252 253 Add_Unit_Supporters (Next_Support_Unit, L); 254 end if; 255 256 -- ???New code end 257 258 Next_Support_Elmt := Next_Elmt (Next_Support_Elmt); 259 260 end loop; 261 262 end if; 263 264 end Add_Unit_Supporters; 265 266 ------------------------- 267 -- Append_Subunit_Name -- 268 ------------------------- 269 270 procedure Append_Subunit_Name (Def_S_Name : Node_Id) is 271 begin 272 -- Here we need unqualified name, because the name 273 -- which comes from the stub is qualified by parent body 274 -- name 275 276 Get_Unqualified_Decoded_Name_String (Chars (Def_S_Name)); 277 278 A_Name_Buffer (A_Name_Len - 1) := '.'; 279 A_Name_Buffer (A_Name_Len .. A_Name_Len + Name_Len - 1) := 280 Name_Buffer (1 .. Name_Len); 281 A_Name_Len := A_Name_Len + Name_Len + 1; 282 A_Name_Buffer (A_Name_Len - 1) := '%'; 283 A_Name_Buffer (A_Name_Len) := 'b'; 284 end Append_Subunit_Name; 285 286 ------------------------ 287 -- CU_To_Unit_Id_List -- 288 ------------------------ 289 290 procedure CU_To_Unit_Id_List 291 (CU_List : Compilation_Unit_List; 292 Result_Unit_Id_List : in out Unit_Id_List; 293 Result_List_Len : out Natural) 294 is 295 Next_Unit : Unit_Id; 296 begin 297 Result_List_Len := 0; 298 299 for I in CU_List'Range loop 300 Next_Unit := Get_Unit_Id (CU_List (I)); 301 302 if not In_List (Next_Unit, Result_Unit_Id_List, Result_List_Len) then 303 Result_List_Len := Result_List_Len + 1; 304 Result_Unit_Id_List (Result_List_Len) := Next_Unit; 305 end if; 306 307 end loop; 308 309 end CU_To_Unit_Id_List; 310 311 --------------------------- 312 -- Fix_Direct_Supporters -- 313 --------------------------- 314 315 procedure Fix_Direct_Supporters (Unit : Unit_Id) is 316 317 function Next_Supporter (U : Unit_Id) return Unit_Id; 318 -- Computes the next supporter to be added (from subunit to the parent 319 -- body, from body to the spec, from child to the parent etc). Ends up 320 -- with Standard and then with Nil_Unit as its parent 321 322 Next_Supporter_Id : Unit_Id; 323 324 function Next_Supporter (U : Unit_Id) return Unit_Id is 325 C : constant Context_Id := Current_Context; 326 Arg_Unit_Kind : constant Unit_Kinds := Kind (C, U); 327 Result_Id : Unit_Id := Nil_Unit; 328 begin 329 330 case Arg_Unit_Kind is 331 332 when A_Procedure | 333 A_Function | 334 A_Package | 335 A_Generic_Procedure | 336 A_Generic_Function | 337 A_Generic_Package | 338 A_Procedure_Instance | 339 A_Function_Instance | 340 A_Package_Instance | 341 A_Procedure_Renaming | 342 A_Function_Renaming | 343 A_Package_Renaming | 344 A_Generic_Procedure_Renaming | 345 A_Generic_Function_Renaming | 346 A_Generic_Package_Renaming => 347 348 Result_Id := Get_Parent_Unit (C, U); 349 350 when A_Procedure_Body | 351 A_Function_Body => 352 353 if Class (C, U) = A_Public_Declaration_And_Body then 354 Result_Id := Get_Parent_Unit (C, U); 355 else 356 Result_Id := Get_Declaration (C, U); 357 end if; 358 359 when A_Package_Body => 360 Result_Id := Get_Declaration (C, U); 361 362 when A_Procedure_Body_Subunit | 363 A_Function_Body_Subunit | 364 A_Package_Body_Subunit | 365 A_Task_Body_Subunit | 366 A_Protected_Body_Subunit => 367 Result_Id := Get_Subunit_Parent_Body (C, U); 368 369 when A_Configuration_Compilation => 370 null; 371 when others => 372 pragma Assert (False); 373 null; 374 end case; 375 376 return Result_Id; 377 end Next_Supporter; 378 379 begin 380 Next_Supporter_Id := Next_Supporter (Unit); 381 382 while Present (Next_Supporter_Id) loop 383 384 Append_Elmt (Unit => Next_Supporter_Id, 385 To => Unit_Table.Table (Unit).Direct_Supporters); 386 387 Next_Supporter_Id := Next_Supporter (Next_Supporter_Id); 388 end loop; 389 390 end Fix_Direct_Supporters; 391 392 -------------------- 393 -- Get_First_Stub -- 394 -------------------- 395 396 function Get_First_Stub (Body_Node : Node_Id) return Node_Id is 397 Decls : List_Id; 398 Decl : Node_Id; 399 begin 400 Decls := Declarations (Body_Node); 401 402 if No (Decls) then 403 return Empty; 404 else 405 Decl := Nlists.First (Decls); 406 407 while Present (Decl) loop 408 409 if Nkind (Decl) in N_Body_Stub then 410 return Decl; 411 end if; 412 413 Decl := Next (Decl); 414 end loop; 415 return Empty; 416 end if; 417 418 end Get_First_Stub; 419 420 ------------------- 421 -- Get_Next_Stub -- 422 ------------------- 423 424 function Get_Next_Stub (Stub_Node : Node_Id) return Node_Id is 425 Next_Decl : Node_Id; 426 begin 427 Next_Decl := Next (Stub_Node); 428 429 while Present (Next_Decl) loop 430 431 if Nkind (Next_Decl) in N_Body_Stub then 432 return Next_Decl; 433 end if; 434 435 Next_Decl := Next (Next_Decl); 436 end loop; 437 return Empty; 438 end Get_Next_Stub; 439 440 ------------- 441 -- In_List -- 442 ------------- 443 444 function In_List 445 (U : Unit_Id; 446 L : Unit_Id_List; 447 Up_To : Natural) 448 return Boolean 449 is 450 Len : constant Natural := Natural'Min (Up_To, L'Length); 451 Result : Boolean := False; 452 begin 453 for I in 1 .. Len loop 454 if L (I) = U then 455 Result := True; 456 exit; 457 end if; 458 end loop; 459 460 return Result; 461 462 end In_List; 463 464 ------------------ 465 -- Process_Stub -- 466 ------------------ 467 468 procedure Process_Stub (C : Context_Id; U : Unit_Id; Stub : Node_Id) is 469 Def_S_Name : Node_Id; 470 Subunit_Id : Unit_Id; 471 begin 472 -- We should save (and then restore) the content of A_Name_Buffer in 473 -- case when more than one stub is to be processed. (A_Name_Buffer 474 -- contains the Ada name of the parent body) 475 476 NB_Save; 477 478 if Nkind (Stub) = N_Subprogram_Body_Stub then 479 Def_S_Name := Defining_Unit_Name (Specification (Stub)); 480 else 481 Def_S_Name := Defining_Identifier (Stub); 482 end if; 483 484 Append_Subunit_Name (Def_S_Name); 485 486 Subunit_Id := Name_Find (C); 487 488 if No (Subunit_Id) then 489 Subunit_Id := Allocate_Nonexistent_Unit_Entry (C); 490 Append_Elmt (Unit => Subunit_Id, 491 To => Unit_Table.Table (U).Subunits_Or_Childs); 492 end if; 493 494 NB_Restore; 495 496 end Process_Stub; 497 498 ------------------------------ 499 -- Reorder_Sem_Dependencies -- 500 ------------------------------ 501 502 procedure Reorder_Sem_Dependencies (Units : Unit_Id_List_Access) is 503 More_Inversion : Boolean := True; 504 Tmp_Unit : Unit_Id; 505 begin 506 507 if Units'Length = 0 then 508 return; 509 end if; 510 511 -- The idea is simple: for all the units in Units list we have the 512 -- lists of all the unit's supporters already computed. If we order 513 -- units so that the lengths of supporter lists will increase we will 514 -- get the order in which there will be no forward semantic 515 -- dependencies: if unit A depends on unit B, then A also depends on 516 -- all the supporters of B, so it has the list of supporters longer 517 -- then B has 518 519 while More_Inversion loop 520 521 More_Inversion := False; 522 523 for J in Units'First .. Units'Last - 1 loop 524 525 if List_Length (Unit_Table.Table (Units (J)).Supporters) > 526 List_Length (Unit_Table.Table (Units (J + 1)).Supporters) 527 then 528 Tmp_Unit := Units (J + 1); 529 Units (J + 1) := Units (J); 530 Units (J) := Tmp_Unit; 531 More_Inversion := True; 532 end if; 533 534 end loop; 535 536 end loop; 537 538 end Reorder_Sem_Dependencies; 539 540 -------------------------- 541 -- Set_All_Dependencies -- 542 -------------------------- 543 544 procedure Set_All_Dependencies (Use_First_New_Unit : Boolean := False) is 545 Starting_Unit : Unit_Id; 546 begin 547 548 if Use_First_New_Unit then 549 Starting_Unit := First_New_Unit; 550 551 if No (Starting_Unit) then 552 -- This may happen, when, for the incremental Context, we 553 -- process the tree which is the main tree for some body unit, 554 -- and this body unit has been already included in the Context 555 -- (See Lib (spec, (h)) 556 return; 557 end if; 558 559 else 560 Starting_Unit := Standard_Id + 1; 561 -- Standard_Id corresponds to last predefined unit set in the 562 -- unit table ??? 563 end if; 564 565 for U in Starting_Unit .. Last_Unit loop 566 Set_All_Unit_Dependencies (U); 567 end loop; 568 end Set_All_Dependencies; 569 570 ------------------------------- 571 -- Set_All_Unit_Dependencies -- 572 ------------------------------- 573 574 procedure Set_All_Unit_Dependencies (U : Unit_Id) is 575 Supporters : Elist_Id renames Unit_Table.Table (U).Supporters; 576 Direct_Supporters : Elist_Id renames 577 Unit_Table.Table (U).Direct_Supporters; 578 579 Next_Support_Elmt : Elmt_Id; 580 Next_Support_Unit : Unit_Id; 581 582 begin 583 584 Fix_Direct_Supporters (U); 585 586 -- Setting all the unit supporters 587 Next_Support_Elmt := First_Elmt (Direct_Supporters); 588 589 while Present (Next_Support_Elmt) loop 590 Next_Support_Unit := Unit (Next_Support_Elmt); 591 592 -- If Next_Support_Unit already is in Supporters list, 593 -- all its supporters also are already included in Supporters. 594 595 if not In_Elmt_List (Next_Support_Unit, Supporters) then 596 Append_Elmt 597 (Unit => Next_Support_Unit, 598 To => Supporters); 599 600 Add_Unit_Supporters (Next_Support_Unit, Supporters); 601 end if; 602 603 Next_Support_Elmt := Next_Elmt (Next_Support_Elmt); 604 605 end loop; 606 607 -- And now - adding U as depended unit to the list of Dependents for 608 -- all its supporters 609 610 Next_Support_Elmt := First_Elmt (Supporters); 611 612 while Present (Next_Support_Elmt) loop 613 Next_Support_Unit := Unit (Next_Support_Elmt); 614 615 Append_Elmt 616 (Unit => U, 617 To => Unit_Table.Table (Next_Support_Unit).Dependents); 618 619 Next_Support_Elmt := Next_Elmt (Next_Support_Elmt); 620 end loop; 621 622 end Set_All_Unit_Dependencies; 623 624 --------------------------- 625 -- Set_Direct_Dependents -- 626 --------------------------- 627 628 procedure Set_Direct_Dependents (U : Unit_Id) is 629 Next_Support_Elmt : Elmt_Id; 630 Next_Support_Unit : Unit_Id; 631 begin 632 Next_Support_Elmt := First_Elmt (Unit_Table.Table (U).Direct_Supporters); 633 634 while Present (Next_Support_Elmt) loop 635 Next_Support_Unit := Unit (Next_Support_Elmt); 636 637 Append_Elmt 638 (Unit => U, 639 To => Unit_Table.Table (Next_Support_Unit).Direct_Dependents); 640 641 Next_Support_Elmt := Next_Elmt (Next_Support_Elmt); 642 end loop; 643 644 end Set_Direct_Dependents; 645 646 ----------------------- 647 -- Set_All_Ancestors -- 648 ----------------------- 649 650 procedure Set_All_Ancestors 651 (Compilation_Units : Asis.Compilation_Unit_List; 652 Result : in out Compilation_Unit_List_Access) 653 is 654 Cont : constant Context_Id := Current_Context; 655 656 Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) := 657 (others => Nil_Unit); 658 659 Arg_List_Len : Natural := 0; 660 Result_List : Unit_Id_List_Access := null; 661 Next_Ancestor_Unit : Unit_Id; 662 663 begin 664 -- For the current version, we are supposing, that we have only one 665 -- Context opened at a time 666 667 CU_To_Unit_Id_List (Compilation_Units, Arg_List, Arg_List_Len); 668 669 -- Standard is an ancestor of any unit, and if we are here, 670 -- Compilation_Units can not be Nil_Compilation_Unit_List. So we set 671 -- it as the first element of the result list: 672 673 Append_Unit_To_List (Standard_Id, Result_List); 674 675 for I in 1 .. Arg_List_Len loop 676 677 Next_Ancestor_Unit := Arg_List (I); 678 679 if Next_Ancestor_Unit /= Standard_Id then 680 681 while Kind (Cont, Next_Ancestor_Unit) in A_Subunit loop 682 Next_Ancestor_Unit := 683 Get_Subunit_Parent_Body (Cont, Next_Ancestor_Unit); 684 end loop; 685 686 if Class (Cont, Next_Ancestor_Unit) = A_Public_Body or else 687 Class (Cont, Next_Ancestor_Unit) = A_Private_Body 688 then 689 Next_Ancestor_Unit := 690 Get_Declaration (Cont, Next_Ancestor_Unit); 691 end if; 692 693 while Next_Ancestor_Unit /= Standard_Id loop 694 695 if not In_Unit_Id_List (Next_Ancestor_Unit, Result_List) then 696 697 Append_Unit_To_List (Next_Ancestor_Unit, Result_List); 698 Next_Ancestor_Unit := 699 Get_Parent_Unit (Cont, Next_Ancestor_Unit); 700 else 701 exit; 702 end if; 703 704 end loop; 705 706 end if; 707 708 end loop; 709 710 -- And here we have to order Result_List to eliminate forward 711 -- semantic dependencies 712 713 -- Result_List can not be null - it contains at least Standard_Id 714 715 Reorder_Sem_Dependencies (Result_List); 716 717 Result := new Compilation_Unit_List' 718 (Get_Comp_Unit_List (Result_List.all, Cont)); 719 Free (Result_List); 720 721 end Set_All_Ancestors; 722 723 ------------------------ 724 -- Set_All_Dependents -- 725 ------------------------ 726 727 procedure Set_All_Dependents 728 (Compilation_Units : Asis.Compilation_Unit_List; 729 Dependent_Units : Asis.Compilation_Unit_List; 730 Result : in out Compilation_Unit_List_Access) 731 is 732 Cont : constant Context_Id := Current_Context; 733 734 Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) := 735 (others => Nil_Unit); 736 737 Arg_List_Len : Natural := 0; 738 739 Dep_List : Unit_Id_List (1 .. Dependent_Units'Length) := 740 (others => Nil_Unit); 741 742 Dep_List_Len : Natural := 0; 743 Result_List : Unit_Id_List_Access := null; 744 Next_Dependent_Elmt : Elmt_Id; 745 Next_Dependent_Unit : Unit_Id; 746 747 begin 748 -- For the current version, we are supposing, that we have only one 749 -- Context opened at a time 750 751 CU_To_Unit_Id_List (Compilation_Units, Arg_List, Arg_List_Len); 752 CU_To_Unit_Id_List (Dependent_Units, Dep_List, Dep_List_Len); 753 754 -- Now, collecting all the dependents for Compilation_Units 755 756 for I in 1 .. Arg_List_Len loop 757 758 Next_Dependent_Elmt := 759 First_Elmt (Unit_Table.Table (Arg_List (I)).Dependents); 760 761 while Present (Next_Dependent_Elmt) loop 762 Next_Dependent_Unit := Unit (Next_Dependent_Elmt); 763 764 if Dep_List_Len = 0 or else 765 In_List (Next_Dependent_Unit, Dep_List, Dep_List_Len) 766 then 767 Add_To_Unit_Id_List (Next_Dependent_Unit, Result_List); 768 end if; 769 770 Next_Dependent_Elmt := Next_Elmt (Next_Dependent_Elmt); 771 772 end loop; 773 774 end loop; 775 776 -- And here we have to order Result_List to eliminate forward 777 -- semantic dependencies 778 779 if Result_List /= null then 780 Reorder_Sem_Dependencies (Result_List); 781 782 Result := new Compilation_Unit_List' 783 (Get_Comp_Unit_List (Result_List.all, Cont)); 784 Free (Result_List); 785 else 786 Result := new Compilation_Unit_List (1 .. 0); 787 end if; 788 789 end Set_All_Dependents; 790 791 ------------------------- 792 -- Set_All_Descendants -- 793 ------------------------- 794 795 procedure Set_All_Descendants 796 (Compilation_Units : Asis.Compilation_Unit_List; 797 Result : in out Compilation_Unit_List_Access) 798 is 799 Cont : constant Context_Id := Current_Context; 800 801 Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) := 802 (others => Nil_Unit); 803 804 Arg_List_Len : Natural := 0; 805 Result_List : Unit_Id_List_Access := null; 806 Next_Descendant_Elmt : Elmt_Id; 807 Next_Unit : Unit_Id; 808 809 procedure Add_All_Descendants 810 (Desc_Unit : Unit_Id; 811 Result_List : in out Unit_Id_List_Access); 812 -- If Desc_Unit is not in Result_List, this procedure adds it and 813 -- (recursively) all its descendants which are not in Result_List to 814 -- the list. 815 816 procedure Add_All_Descendants 817 (Desc_Unit : Unit_Id; 818 Result_List : in out Unit_Id_List_Access) 819 is 820 Child_Elmt : Elmt_Id; 821 Child_Unit : Unit_Id; 822 begin 823 824 if not In_Unit_Id_List (Desc_Unit, Result_List) then 825 Append_Unit_To_List (Desc_Unit, Result_List); 826 827 if Kind (Cont, Desc_Unit) = A_Package or else 828 Kind (Cont, Desc_Unit) = A_Generic_Package or else 829 Kind (Cont, Desc_Unit) = A_Package_Renaming or else 830 Kind (Cont, Desc_Unit) = A_Generic_Package_Renaming 831 then 832 Child_Elmt := 833 First_Elmt (Unit_Table.Table (Desc_Unit).Subunits_Or_Childs); 834 835 while Present (Child_Elmt) loop 836 Child_Unit := Unit (Child_Elmt); 837 838 Add_All_Descendants (Child_Unit, Result_List); 839 840 Child_Elmt := Next_Elmt (Child_Elmt); 841 end loop; 842 843 end if; 844 845 end if; 846 847 end Add_All_Descendants; 848 849 begin 850 851 -- We can not use CU_To_Unit_Id_List routine, because we have to 852 -- filter out subunits, nonexistent units (?) and bodies for which the 853 -- Context does not contain a spec - such units can not have 854 -- descendants. For bodies, only the corresponding specs contain the 855 -- lists of descendants. 856 857 for I in Compilation_Units'Range loop 858 Next_Unit := Get_Unit_Id (Compilation_Units (I)); 859 860 if Kind (Cont, Next_Unit) not in A_Procedure_Body_Subunit .. 861 A_Nonexistent_Body 862 then 863 864 if Kind (Cont, Next_Unit) in A_Library_Unit_Body then 865 Next_Unit := Get_Declaration (Cont, Next_Unit); 866 end if; 867 868 if Present (Next_Unit) and then 869 (not In_List (Next_Unit, Arg_List, Arg_List_Len)) 870 then 871 Arg_List_Len := Arg_List_Len + 1; 872 Arg_List (Arg_List_Len) := Next_Unit; 873 end if; 874 875 end if; 876 877 end loop; 878 879 for J in 1 .. Arg_List_Len loop 880 Next_Descendant_Elmt := 881 First_Elmt (Unit_Table.Table (Arg_List (J)).Subunits_Or_Childs); 882 883 while Present (Next_Descendant_Elmt) loop 884 Next_Unit := Unit (Next_Descendant_Elmt); 885 Add_All_Descendants (Next_Unit, Result_List); 886 Next_Descendant_Elmt := Next_Elmt (Next_Descendant_Elmt); 887 end loop; 888 889 end loop; 890 891 if Result_List /= null then 892 Reorder_Sem_Dependencies (Result_List); 893 894 Result := new Compilation_Unit_List' 895 (Get_Comp_Unit_List (Result_List.all, Cont)); 896 Free (Result_List); 897 else 898 Result := new Compilation_Unit_List (1 .. 0); 899 end if; 900 901 end Set_All_Descendants; 902 903 ---------------------- 904 -- Set_All_Families -- 905 ---------------------- 906 907 procedure Set_All_Families 908 (Compilation_Units : Asis.Compilation_Unit_List; 909 Result : in out Compilation_Unit_List_Access) 910 is 911 Cont : constant Context_Id := Current_Context; 912 913 Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) := 914 (others => Nil_Unit); 915 916 Arg_List_Len : Natural := 0; 917 Result_List : Unit_Id_List_Access := null; 918 919 procedure Collect_Spec_Family 920 (Spec_Unit : Unit_Id; 921 Result_List : in out Unit_Id_List_Access); 922 -- If Spec_Unit is not in Result_List, this procedure adds it and 923 -- (recursively) all members of its family which are not in Result_List 924 -- to the list. In case of a spec, the corresponding body's family is 925 -- also added 926 927 procedure Collect_Body_Family 928 (Body_Unit : Unit_Id; 929 Result_List : in out Unit_Id_List_Access); 930 -- If Body_Unit is not in Result_List, this procedure adds it and 931 -- (recursively) all members of its family which are not in Result_List 932 -- to the list. In case of a body, only the subunit tree rooted by this 933 -- body may be added 934 935 procedure Collect_Spec_Family 936 (Spec_Unit : Unit_Id; 937 Result_List : in out Unit_Id_List_Access) 938 is 939 Child_Elmt : Elmt_Id; 940 Child_Unit : Unit_Id; 941 begin 942 943 if not In_Unit_Id_List (Spec_Unit, Result_List) then 944 Append_Unit_To_List (Spec_Unit, Result_List); 945 946 -- We have to add all descendants (if any) and their families 947 948 if Kind (Cont, Spec_Unit) = A_Package or else 949 Kind (Cont, Spec_Unit) = A_Generic_Package or else 950 Kind (Cont, Spec_Unit) = A_Package_Renaming or else 951 Kind (Cont, Spec_Unit) = A_Generic_Package_Renaming 952 then 953 Child_Elmt := 954 First_Elmt (Unit_Table.Table (Spec_Unit).Subunits_Or_Childs); 955 956 while Present (Child_Elmt) loop 957 Child_Unit := Unit (Child_Elmt); 958 959 if Kind (Cont, Child_Unit) in 960 A_Procedure .. A_Generic_Package_Renaming 961 then 962 963 Collect_Spec_Family (Child_Unit, Result_List); 964 965 elsif Kind (Cont, Child_Unit) in 966 A_Procedure_Body .. A_Protected_Body_Subunit 967 then 968 969 Collect_Body_Family (Child_Unit, Result_List); 970 971 end if; 972 973 Child_Elmt := Next_Elmt (Child_Elmt); 974 end loop; 975 976 end if; 977 978 end if; 979 980 end Collect_Spec_Family; 981 982 procedure Collect_Body_Family 983 (Body_Unit : Unit_Id; 984 Result_List : in out Unit_Id_List_Access) 985 is 986 Child_Elmt : Elmt_Id; 987 Child_Unit : Unit_Id; 988 begin 989 990 if not In_Unit_Id_List (Body_Unit, Result_List) then 991 Append_Unit_To_List (Body_Unit, Result_List); 992 993 -- We have to add all descendants (if any) and their families 994 995 if Kind (Cont, Body_Unit) in 996 A_Procedure_Body .. A_Protected_Body_Subunit 997 then 998 Child_Elmt := 999 First_Elmt (Unit_Table.Table (Body_Unit).Subunits_Or_Childs); 1000 1001 while Present (Child_Elmt) loop 1002 Child_Unit := Unit (Child_Elmt); 1003 Collect_Body_Family (Child_Unit, Result_List); 1004 Child_Elmt := Next_Elmt (Child_Elmt); 1005 end loop; 1006 1007 end if; 1008 1009 end if; 1010 1011 end Collect_Body_Family; 1012 1013 begin 1014 CU_To_Unit_Id_List (Compilation_Units, Arg_List, Arg_List_Len); 1015 1016 for J in 1 .. Arg_List_Len loop 1017 1018 case Class (Cont, Arg_List (J)) is 1019 1020 when A_Public_Declaration | 1021 A_Private_Declaration => 1022 1023 Collect_Spec_Family (Arg_List (J), Result_List); 1024 1025 when Not_A_Class => 1026 -- This should never happen, so just in case we 1027 -- raise an exception 1028 null; 1029 pragma Assert (False); 1030 1031 when others => 1032 -- Here we can have only a body or a separate body 1033 Collect_Body_Family (Arg_List (J), Result_List); 1034 end case; 1035 1036 end loop; 1037 1038 -- And here we have to order Result_List to eliminate forward 1039 -- semantic dependencies 1040 1041 if Result_List /= null then 1042 Reorder_Sem_Dependencies (Result_List); 1043 1044 Result := new Compilation_Unit_List' 1045 (Get_Comp_Unit_List (Result_List.all, Cont)); 1046 Free (Result_List); 1047 else 1048 Result := new Compilation_Unit_List (1 .. 0); 1049 end if; 1050 1051 end Set_All_Families; 1052 1053 ------------------------ 1054 -- Set_All_Supporters -- 1055 ------------------------ 1056 1057 package Unit_Container is new Ada.Containers.Ordered_Sets 1058 (Element_Type => Unit_Id); 1059 1060 procedure Unit_List_To_Set 1061 (Unit_List : Elist_Id; 1062 Unit_Set : in out Unit_Container.Set); 1063 -- Assuming that Unit_List does not contain repeating elements, creates 1064 -- Unit_Set as the set containing Unit IDs from Unit_List. If Unit_Set is 1065 -- non-empty before the call, the old content of the set is lost. 1066 1067 function Unit_Set_To_List 1068 (Unit_Set : Unit_Container.Set) 1069 return Unit_Id_List; 1070 -- Converts the unit id set into array 1071 1072 Result_Set : Unit_Container.Set; 1073 New_Set : Unit_Container.Set; 1074 Newer_Set : Unit_Container.Set; 1075 Next_Direct_Supporter : Unit_Container.Cursor; 1076 1077 procedure Unit_List_To_Set 1078 (Unit_List : Elist_Id; 1079 Unit_Set : in out Unit_Container.Set) 1080 is 1081 Next_El : Elmt_Id; 1082 begin 1083 Unit_Container.Clear (Unit_Set); 1084 1085 Next_El := First_Elmt (Unit_List); 1086 1087 while Present (Next_El) loop 1088 Unit_Container.Insert (Unit_Set, Unit (Next_El)); 1089 Next_El := Next_Elmt (Next_El); 1090 end loop; 1091 end Unit_List_To_Set; 1092 1093 function Unit_Set_To_List 1094 (Unit_Set : Unit_Container.Set) 1095 return Unit_Id_List 1096 is 1097 Next_Unit : Unit_Container.Cursor; 1098 Result : Unit_Id_List (1 .. Natural (Unit_Container.Length (Unit_Set))); 1099 Next_Idx : Natural := Result'First; 1100 begin 1101 Next_Unit := Unit_Container.First (Unit_Set); 1102 1103 while Unit_Container.Has_Element (Next_Unit) loop 1104 Result (Next_Idx) := Unit_Container.Element (Next_Unit); 1105 Next_Idx := Next_Idx + 1; 1106 Next_Unit := Unit_Container.Next (Next_Unit); 1107 end loop; 1108 1109 return Result; 1110 end Unit_Set_To_List; 1111 1112 procedure Set_All_Supporters 1113 (Compilation_Units : Asis.Compilation_Unit_List; 1114 Result : in out Compilation_Unit_List_Access) 1115 1116 is 1117 Cont : constant Context_Id := Current_Context; 1118 1119 Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) := 1120 (others => Nil_Unit); 1121 1122 Result_List : Unit_Id_List_Access := null; 1123 Arg_List_Len : Natural := 0; 1124 pragma Unreferenced (Arg_List_Len); 1125 1126 procedure Collect_Supporters (U : Unit_Id); 1127 -- If U is not presented in Result, adds (recursively) all its 1128 -- supporters to Result_List 1129 -- Uses workpile algorithm to avoid cycling (cycling is possible because 1130 -- of limited with) 1131 1132 procedure Collect_Supporters (U : Unit_Id) is 1133 Next_Supporter : Elmt_Id; 1134 begin 1135 1136 Unit_Container.Clear (New_Set); 1137 Unit_Container.Clear (Newer_Set); 1138 1139 Unit_List_To_Set 1140 (Unit_List => Unit_Table.Table (U).Supporters, 1141 Unit_Set => New_Set); 1142 1143 Unit_Container.Union 1144 (Target => Result_Set, 1145 Source => New_Set); 1146 1147 while not Unit_Container.Is_Empty (New_Set) loop 1148 Next_Direct_Supporter := Unit_Container.First (New_Set); 1149 1150 Next_Supporter := 1151 First_Elmt (Unit_Table.Table 1152 (Unit_Container.Element (Next_Direct_Supporter)).Supporters); 1153 1154 while Present (Next_Supporter) loop 1155 if not Unit_Container.Contains 1156 (Result_Set, Unit (Next_Supporter)) 1157 then 1158 Unit_Container.Insert (Newer_Set, Unit (Next_Supporter)); 1159 end if; 1160 1161 Next_Supporter := Next_Elmt (Next_Supporter); 1162 end loop; 1163 1164 Unit_Container.Delete_First (New_Set); 1165 1166 if not Unit_Container.Is_Empty (Newer_Set) then 1167 Unit_Container.Union (Result_Set, Newer_Set); 1168 Unit_Container.Union (New_Set, Newer_Set); 1169 Unit_Container.Clear (Newer_Set); 1170 end if; 1171 end loop; 1172 1173 end Collect_Supporters; 1174 1175 begin 1176 Unit_Container.Clear (Result_Set); 1177 Unit_Container.Insert (Result_Set, Standard_Id); 1178 1179 -- For the current version, we are supposing, that we have only one 1180 -- Context opened at a time 1181 1182 CU_To_Unit_Id_List (Compilation_Units, Arg_List, Arg_List_Len); 1183 1184 -- Now, collecting all the supporters for Compilation_Units 1185 1186 -- Standard is a supporter of any unit, and if we are here, 1187 -- Compilation_Units can not be Nil_Compilation_Unit_List. So we set 1188 -- it as the first element of the result list: 1189 1190 for J in Compilation_Units'Range loop 1191 Collect_Supporters (Get_Unit_Id (Compilation_Units (J))); 1192 end loop; 1193 1194 Result_List := new Unit_Id_List'(Unit_Set_To_List (Result_Set)); 1195 1196 -- And here we have to order Result_List to eliminate forward 1197 -- semantic dependencies 1198 1199 -- Result_List can not be null - it contains at least Standard_Id 1200 1201 Reorder_Sem_Dependencies (Result_List); 1202 1203 Result := new Compilation_Unit_List' 1204 (Get_Comp_Unit_List (Result_List.all, Cont)); 1205 Free (Result_List); 1206 1207 end Set_All_Supporters; 1208 1209 -------------------------- 1210 -- Set_All_Needed_Units -- 1211 -------------------------- 1212 1213 procedure Set_All_Needed_Units 1214 (Compilation_Units : Asis.Compilation_Unit_List; 1215 Result : in out Compilation_Unit_List_Access; 1216 Missed : in out Compilation_Unit_List_Access) 1217 is 1218 Cont : constant Context_Id := Current_Context; 1219 Cont_Tree_Mode : constant Tree_Mode := Tree_Processing_Mode (Cont); 1220 1221 Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) := 1222 (others => Nil_Unit); 1223 Arg_List_Len : Natural := 0; 1224 1225 Result_List : Unit_Id_List_Access := null; 1226 Missed_List : Unit_Id_List_Access := null; 1227 1228 procedure Set_One_Unit (U : Unit_Id); 1229 -- Provided that U is an (existing) unit which is not in the 1230 -- Result_List, this procedure adds this unit and all the units 1231 -- needed by it to result lists. 1232 1233 procedure Add_Needed_By_Spec (Spec_Unit : Unit_Id); 1234 -- Provided that Spec_Unit denotes an (existing) spec, this procedure 1235 -- adds to the result lists units which are needed by this unit only, 1236 -- that is, excluding this unit (it is supposed to be already added at 1237 -- the moment of the call), its body and units needed by the body (if 1238 -- any, they are processed separately) 1239 1240 procedure Add_Needed_By_Body (Body_Unit : Unit_Id); 1241 -- Provided that Body_Unit denotes an (existing) body, this procedure 1242 -- adds to the result lists units which are needed by this unit, 1243 -- excluding the unit itself (it is supposed to be already added at 1244 -- the moment of the call). That is, the spec of this unit and units 1245 -- which are needed by the spec (if any) are also needed, if they have 1246 -- not been added before 1247 1248 ------------------------ 1249 -- Add_Needed_By_Body -- 1250 ------------------------ 1251 1252 procedure Add_Needed_By_Body (Body_Unit : Unit_Id) is 1253 Spec_Unit : Unit_Id; 1254 1255 Subunit_List : constant Unit_Id_List := Subunits (Cont, Body_Unit); 1256 1257 Next_Support_Elmt : Elmt_Id; 1258 Next_Support_Unit : Unit_Id; 1259 1260 begin 1261 1262 -- First, check if there is a separate spec then it has to be 1263 -- processed 1264 1265 if Class (Cont, Body_Unit) /= A_Public_Declaration_And_Body then 1266 1267 Spec_Unit := Body_Unit; 1268 1269 while Class (Cont, Spec_Unit) = A_Separate_Body loop 1270 Spec_Unit := Get_Subunit_Parent_Body (Cont, Spec_Unit); 1271 end loop; 1272 1273 Spec_Unit := Get_Declaration (Cont, Spec_Unit); 1274 -- We can not get Nil or nonexistent unit here 1275 1276 if not In_Unit_Id_List (Spec_Unit, Result_List) then 1277 Add_Needed_By_Spec (Spec_Unit); 1278 end if; 1279 1280 end if; 1281 1282 -- Now process body's supporters: 1283 1284 Next_Support_Elmt := 1285 First_Elmt (Unit_Table.Table (Body_Unit).Supporters); 1286 1287 while Present (Next_Support_Elmt) loop 1288 1289 Next_Support_Unit := Unit (Next_Support_Elmt); 1290 1291 if not In_Unit_Id_List (Next_Support_Unit, Result_List) then 1292 Set_One_Unit (Next_Support_Unit); 1293 end if; 1294 1295 Next_Support_Elmt := Next_Elmt (Next_Support_Elmt); 1296 1297 end loop; 1298 1299 -- And, finally, subunits: 1300 1301 for J in Subunit_List'Range loop 1302 1303 if Kind (Cont, Subunit_List (J)) = A_Nonexistent_Body then 1304 Append_Unit_To_List (Subunit_List (J), Missed_List); 1305 1306 elsif not In_Unit_Id_List (Subunit_List (J), Result_List) then 1307 Append_Unit_To_List (Subunit_List (J), Result_List); 1308 Add_Needed_By_Body (Subunit_List (J)); 1309 end if; 1310 1311 end loop; 1312 1313 end Add_Needed_By_Body; 1314 1315 ------------------------ 1316 -- Add_Needed_By_Spec -- 1317 ------------------------ 1318 1319 procedure Add_Needed_By_Spec (Spec_Unit : Unit_Id) is 1320 Next_Support_Elmt : Elmt_Id; 1321 Next_Support_Unit : Unit_Id; 1322 begin 1323 1324 Next_Support_Elmt := 1325 First_Elmt (Unit_Table.Table (Spec_Unit).Supporters); 1326 1327 while Present (Next_Support_Elmt) loop 1328 1329 Next_Support_Unit := Unit (Next_Support_Elmt); 1330 1331 if not In_Unit_Id_List (Next_Support_Unit, Result_List) then 1332 Set_One_Unit (Next_Support_Unit); 1333 end if; 1334 1335 Next_Support_Elmt := Next_Elmt (Next_Support_Elmt); 1336 1337 end loop; 1338 1339 end Add_Needed_By_Spec; 1340 1341 ------------------ 1342 -- Set_One_Unit -- 1343 ------------------ 1344 1345 procedure Set_One_Unit (U : Unit_Id) is 1346 U_Body : Unit_Id; 1347 begin 1348 Append_Unit_To_List (U, Result_List); 1349 1350 case Class (Cont, U) is 1351 1352 when A_Public_Declaration | 1353 A_Private_Declaration => 1354 1355 Add_Needed_By_Spec (U); 1356 1357 if Is_Body_Required (Cont, U) then 1358 U_Body := Get_Body (Cont, U); 1359 1360 if No (U_Body) and then 1361 (Cont_Tree_Mode = On_The_Fly 1362 or else 1363 Cont_Tree_Mode = Mixed) 1364 then 1365 -- Is it a correct thing to compile something on the fly 1366 -- Inside the query from Relations??? 1367 U_Body := Get_One_Unit 1368 (Name => To_Program_Text 1369 (Unit_Name (Get_Comp_Unit (U, Cont))), 1370 Context => Cont, 1371 Spec => False); 1372 end if; 1373 1374 if Present (U_Body) then 1375 1376 if Kind (Cont, U_Body) in A_Nonexistent_Declaration .. 1377 A_Nonexistent_Body 1378 then 1379 Add_To_Unit_Id_List (U_Body, Missed_List); 1380 1381 elsif not In_Unit_Id_List (U_Body, Result_List) then 1382 Append_Unit_To_List (U_Body, Result_List); 1383 Add_Needed_By_Body (U_Body); 1384 end if; 1385 1386 else 1387 U_Body := Get_Nonexistent_Unit (Cont); 1388 Append_Unit_To_List (U_Body, Missed_List); 1389 end if; 1390 1391 end if; 1392 1393 when Not_A_Class => 1394 -- This should never happen, so just in case we 1395 -- raise an exception 1396 null; 1397 pragma Assert (False); 1398 1399 when others => 1400 Add_Needed_By_Body (U); 1401 end case; 1402 1403 end Set_One_Unit; 1404 1405 begin -- Set_All_Needed_Units 1406 1407 CU_To_Unit_Id_List (Compilation_Units, Arg_List, Arg_List_Len); 1408 1409 -- Standard is a supporter of any unit, and if we are here, 1410 -- Compilation_Units can not be Nil_Compilation_Unit_List. So we set 1411 -- it as the first element of the result list: 1412 1413 Append_Unit_To_List (Standard_Id, Result_List); 1414 1415 for J in 1 .. Arg_List_Len loop 1416 1417 if not In_Unit_Id_List (Arg_List (J), Result_List) then 1418 Set_One_Unit (Arg_List (J)); 1419 end if; 1420 1421 end loop; 1422 1423 -- Result_List can not be null - it contains at least Standard_Id 1424 1425 Reorder_Sem_Dependencies (Result_List); 1426 1427 Result := new Compilation_Unit_List' 1428 (Get_Comp_Unit_List (Result_List.all, Cont)); 1429 Free (Result_List); 1430 1431 if Missed_List /= null then 1432 Missed := new Compilation_Unit_List' 1433 (Get_Comp_Unit_List (Missed_List.all, Cont)); 1434 Free (Missed_List); 1435 else 1436 Missed := new Compilation_Unit_List (1 .. 0); 1437 end if; 1438 1439 end Set_All_Needed_Units; 1440 1441 ------------------ 1442 -- Set_Subunits -- 1443 ------------------ 1444 1445 procedure Set_Subunits (C : Context_Id; U : Unit_Id; Top : Node_Id) is 1446 Body_Node : Node_Id; 1447 Stub_Node : Node_Id; 1448 begin 1449 Get_Name_String (U, Norm_Ada_Name); 1450 Body_Node := Unit (Top); 1451 1452 if Nkind (Body_Node) = N_Subunit then 1453 Body_Node := Proper_Body (Body_Node); 1454 end if; 1455 1456 Stub_Node := Get_First_Stub (Body_Node); 1457 1458 if No (Stub_Node) then 1459 return; 1460 end if; 1461 1462 while Present (Stub_Node) loop 1463 Process_Stub (C, U, Stub_Node); 1464 Stub_Node := Get_Next_Stub (Stub_Node); 1465 end loop; 1466 1467 Unit_Table.Table (U).Subunits_Computed := True; 1468 1469 end Set_Subunits; 1470 1471 -------------------- 1472 -- Set_Supporters -- 1473 -------------------- 1474 1475 procedure Set_Supporters (C : Context_Id; U : Unit_Id; Top : Node_Id) is 1476 begin 1477 Set_Withed_Units (C, U, Top); 1478 Set_Direct_Dependents (U); 1479 end Set_Supporters; 1480 1481 ---------------------- 1482 -- Set_Withed_Units -- 1483 ---------------------- 1484 1485 procedure Set_Withed_Units (C : Context_Id; U : Unit_Id; Top : Node_Id) 1486 is 1487 With_Clause_Node : Node_Id; 1488 Cunit_Node : Node_Id; 1489 Cunit_Number : Unit_Number_Type; 1490 Current_Supporter : Unit_Id; 1491 Tmp : Unit_Id; 1492 Include_Unit : Boolean := False; 1493 begin 1494 -- the maim control structure - cycle through the with clauses 1495 -- in the tree 1496 if No (Context_Items (Top)) then 1497 return; 1498 end if; 1499 1500 With_Clause_Node := First_Non_Pragma (Context_Items (Top)); 1501 1502 while Present (With_Clause_Node) loop 1503 -- here we simply get the name of the next supporting unit from 1504 -- the GNAT Units Table (defined in Lib) 1505 Cunit_Node := Library_Unit (With_Clause_Node); 1506 Cunit_Number := Get_Cunit_Unit_Number (Cunit_Node); 1507 Get_Decoded_Name_String (Unit_Name (Cunit_Number)); 1508 1509 Set_Norm_Ada_Name_String_With_Check (Cunit_Number, Include_Unit); 1510 1511 if Include_Unit then 1512 1513 Current_Supporter := Name_Find (C); 1514 1515 if A_Name_Buffer (A_Name_Len) = 'b' then 1516 A_Name_Buffer (A_Name_Len) := 's'; 1517 Tmp := Name_Find (C); 1518 1519 if Present (Tmp) then 1520 -- OPEN PROBLEM: is this the best solution for this problem? 1521 -- 1522 -- Here we are in the potentially hard-to-report-about and 1523 -- definitely involving inconsistent unit set situation. 1524 -- The last version of U depends on subprogram body at least 1525 -- in one of the consistent trees, but the Context contains 1526 -- a spec (that is, a library_unit_declaration or a 1527 -- library_unit_renaming_declaration) for the same full 1528 -- expanded Ada name. The current working decision is 1529 -- to set this dependency as if U depends on the spec. 1530 -- 1531 -- Another (crazy!) problem: in one consistent tree 1532 -- U depends on the package P (and P does not require a 1533 -- body), and in another consistent tree U depends on 1534 -- the procedure P which is presented by its body only. 1535 -- It may be quite possible, if these trees were created 1536 -- with different search paths. Is our decision reasonable 1537 -- for this crazy situation :-[ ??!!?? 1538 1539 Current_Supporter := Tmp; 1540 end if; 1541 1542 end if; 1543 1544 -- and now we store this dependency - we have to use 1545 -- Add_To_Elmt_List instead of Append_Elmt - some units 1546 -- may be mentioned several times in the context clause: 1547 if Implicit_With (With_Clause_Node) then 1548 Add_To_Elmt_List 1549 (Unit => Current_Supporter, 1550 List => Unit_Table.Table (U).Implicit_Supporters); 1551 else 1552 Add_To_Elmt_List 1553 (Unit => Current_Supporter, 1554 List => Unit_Table.Table (U).Direct_Supporters); 1555 end if; 1556 end if; 1557 1558 With_Clause_Node := Next_Non_Pragma (With_Clause_Node); 1559 1560 while Present (With_Clause_Node) and then 1561 Nkind (With_Clause_Node) /= N_With_Clause 1562 loop 1563 With_Clause_Node := Next_Non_Pragma (With_Clause_Node); 1564 end loop; 1565 1566 end loop; 1567 end Set_Withed_Units; 1568 1569 ------------------------------------------------------- 1570 -- Dynamic Unit_Id list abstraction (implementation) -- 1571 ------------------------------------------------------- 1572 1573 ---------------------- 1574 -- In_Unit_Id_List -- 1575 ---------------------- 1576 1577 function In_Unit_Id_List 1578 (U : Unit_Id; 1579 L : Unit_Id_List_Access) 1580 return Boolean 1581 is 1582 begin 1583 1584 if L /= null then 1585 1586 for I in L'Range loop 1587 1588 if U = L (I) then 1589 return True; 1590 end if; 1591 1592 end loop; 1593 1594 end if; 1595 1596 return False; 1597 end In_Unit_Id_List; 1598 1599 -------------------------- 1600 -- Add_To_Unit_Id_List -- 1601 -------------------------- 1602 1603 procedure Add_To_Unit_Id_List 1604 (U : Unit_Id; 1605 L : in out Unit_Id_List_Access) 1606 is 1607 begin 1608 1609 if not In_Unit_Id_List (U, L) then 1610 Append_Unit_To_List (U, L); 1611 end if; 1612 1613 end Add_To_Unit_Id_List; 1614 1615 ------------------------- 1616 -- Append_Unit_To_List -- 1617 ------------------------- 1618 1619 procedure Append_Unit_To_List 1620 (U : Unit_Id; 1621 L : in out Unit_Id_List_Access) 1622 is 1623 begin 1624 1625 if L = null then 1626 L := new Unit_Id_List'(1 => U); 1627 else 1628 Free (Tmp_Unit_Id_List_Access); 1629 Tmp_Unit_Id_List_Access := new Unit_Id_List'(L.all & U); 1630 Free (L); 1631 L := new Unit_Id_List'(Tmp_Unit_Id_List_Access.all); 1632 end if; 1633 1634 end Append_Unit_To_List; 1635 1636end A4G.Contt.Dp; 1637