1------------------------------------------------------------------------------ 2-- -- 3-- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- 4-- -- 5-- A 4 G . C O N T T . T T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1995-2013, 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 2, 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. See the GNU General -- 17-- Public License for more details. You should have received a copy of the -- 18-- GNU General Public License distributed with ASIS-for-GNAT; see file -- 19-- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- 20-- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- 21-- -- 22-- -- 23-- -- 24-- -- 25-- -- 26-- -- 27-- -- 28-- -- 29-- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- 30-- Software Engineering Laboratory of the Swiss Federal Institute of -- 31-- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- 32-- Scientific Research Computer Center of Moscow State University (SRCC -- 33-- MSU), Russia, with funding partially provided by grants from the Swiss -- 34-- National Science Foundation and the Swiss Academy of Engineering -- 35-- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- 36-- (http://www.adacore.com). -- 37-- -- 38------------------------------------------------------------------------------ 39pragma Ada_2012; 40-- This package defines Tree Table, which contains the information 41-- about the tree output files needed for swapping the ASTs accessed 42-- by ASIS. This information includes such things as Asis Compilation 43-- Units, and their top nodes in the tree. 44 45with Asis; use Asis; 46with Asis.Compilation_Units; 47with Asis.Errors; use Asis.Errors; 48 49with Asis.Set_Get; use Asis.Set_Get; 50 51with A4G.A_Debug; use A4G.A_Debug; 52with A4G.A_Output; use A4G.A_Output; 53with A4G.Asis_Tables; use A4G.Asis_Tables; 54with A4G.Contt.UT; use A4G.Contt.UT; 55with A4G.Get_Unit; use A4G.Get_Unit; 56with A4G.Vcheck; use A4G.Vcheck; 57 58with Atree; use Atree; 59with Lib; use Lib; 60with Namet; use Namet; 61with Nlists; use Nlists; 62with Output; use Output; 63with Sinfo; use Sinfo; 64with Sinput; use Sinput; 65with Tree_In; 66 67package body A4G.Contt.TT is 68 69 procedure Set_Nil_Tree_Names (T : Tree_Id); 70 -- Sets all the fields related to Source File Name Table as indicating 71 -- empty strings 72 73 procedure Set_Nil_Tree_Attributes (T : Tree_Id); 74 -- Sets all the attributes of T as if T is an ASIS Nil_Tree 75 76 function Find_Enclosed_Decl 77 (Scope : Node_Id; 78 J : Int) 79 return Node_Id; 80 -- Starting from Scope, looks for the nested scope which is stored 81 -- in Node_Trace table as Node_Trase.Table (J). Node, that expanded 82 -- generic specs are considered as ordinary scopes. 83 84 ------------------------- 85 -- Allocate_Tree_Entry -- 86 ------------------------- 87 88 function Allocate_Tree_Entry return Tree_Id is 89 New_Last : Tree_Id; 90 -- the Id of the new entry being allocated in the Unit Table 91 begin 92 93 Tree_Table.Increment_Last; 94 New_Last := Tree_Table.Last; 95 96 Set_Nil_Tree_Names (New_Last); 97 Set_Nil_Tree_Attributes (New_Last); 98 99 Tree_Table.Table (New_Last).Tree_Name_Chars_Index := A_Name_Chars.Last; 100 101 Tree_Table.Table (New_Last).Tree_Name_Len := Short (A_Name_Len); 102 103 -- Set corresponding string entry in the Name_Chars table 104 105 for I in 1 .. A_Name_Len loop 106 A_Name_Chars.Increment_Last; 107 108 A_Name_Chars.Table (A_Name_Chars.Last) := A_Name_Buffer (I); 109 end loop; 110 111 A_Name_Chars.Increment_Last; 112 A_Name_Chars.Table (A_Name_Chars.Last) := ASCII.NUL; 113 return New_Last; 114 115 end Allocate_Tree_Entry; 116 117 ------------------------------------------ 118 -- Current_Tree_Consistent_With_Sources -- 119 ------------------------------------------ 120 121 function Current_Tree_Consistent_With_Sources return Boolean is 122 Result : Boolean := True; 123 Source_Stamp : Time_Stamp_Type; 124 Tree_Stamp : Time_Stamp_Type; 125 Source : File_Name_Type; 126 begin 127 128 for J in 2 .. Last_Source_File loop 129 -- We start from 2, because the entry 1 in the Source File Table 130 -- is always for system.ads (see Sinput, spec). 131 Tree_Stamp := Time_Stamp (J); 132 133 Source := Full_File_Name (J); 134 135 Get_Name_String (Source); 136 Name_Len := Name_Len + 1; 137 Name_Buffer (Name_Len) := ASCII.NUL; 138 139 if not Is_Regular_File (Name_Buffer) then 140 -- The source file was (re)moved 141 Result := False; 142 exit; 143 144 else 145 Source_Stamp := TS_From_OS_Time (File_Time_Stamp (Name_Buffer)); 146 147 if Source_Stamp /= Tree_Stamp then 148 -- The source file has been changed 149 Result := False; 150 exit; 151 end if; 152 153 end if; 154 155 end loop; 156 157 return Result; 158 159 end Current_Tree_Consistent_With_Sources; 160 161 ------------------------ 162 -- Find_Enclosed_Decl -- 163 ------------------------ 164 165 function Find_Enclosed_Decl 166 (Scope : Node_Id; 167 J : Int) 168 return Node_Id 169 is 170 Result : Node_Id := Empty; 171 172 List_To_Search : List_Id; 173 Kind_To_Search : constant Node_Kind := Node_Trace.Table (J).Kind; 174 175 Line_To_Search : constant Physical_Line_Number := 176 Node_Trace.Table (J).Node_Line; 177 178 Col_To_Search : constant Column_Number := 179 Node_Trace.Table (J).Node_Col; 180 181 function Check_Node (N : Node_Id) return Traverse_Result; 182 -- Check if N is the needed node. If it is, Sets Result equial to N and 183 -- returns Abandon. Othervise returns OK. 184 185 function Find_In_List (L : List_Id) return Node_Id; 186 -- Looks for the needed scope in a node list 187 188 procedure Traverse_Scope is new 189 Atree.Traverse_Proc (Process => Check_Node); 190 191 function Check_Node (N : Node_Id) return Traverse_Result is 192 N_Sloc : Source_Ptr; 193 Traverse_Res : Traverse_Result := OK; 194 begin 195 196 if Nkind (N) = Kind_To_Search then 197 N_Sloc := Sloc (N); 198 199 if Get_Physical_Line_Number (N_Sloc) = Line_To_Search 200 and then 201 Get_Column_Number (N_Sloc) = Col_To_Search 202 then 203 Result := N; 204 Traverse_Res := Abandon; 205 end if; 206 207 end if; 208 209 return Traverse_Res; 210 end Check_Node; 211 212 function Find_In_List (L : List_Id) return Node_Id is 213 Res : Node_Id := Empty; 214 Next_Node : Node_Id; 215 Next_Sloc : Source_Ptr; 216 begin 217 Next_Node := First_Non_Pragma (L); 218 219 while Present (Next_Node) loop 220 221 if Nkind (Next_Node) = Kind_To_Search then 222 Next_Sloc := Sloc (Next_Node); 223 224 if Get_Physical_Line_Number (Next_Sloc) = Line_To_Search 225 and then 226 Get_Column_Number (Next_Sloc) = Col_To_Search 227 then 228 Res := Next_Node; 229 exit; 230 end if; 231 232 end if; 233 234 Next_Node := Next_Non_Pragma (Next_Node); 235 236 end loop; 237 238 return Res; 239 end Find_In_List; 240 241 begin 242 243 if Nkind (Scope) = N_Package_Instantiation then 244 Result := Scope; 245 246 while Nkind (Result) /= N_Package_Declaration loop 247 Result := Prev_Non_Pragma (Result); 248 end loop; 249 250 return Result; 251 252 end if; 253 254 if Nkind (Scope) = N_Package_Body 255 or else 256 Nkind (Scope) = N_Subprogram_Body 257 or else 258 Nkind (Scope) = N_Block_Statement 259 then 260 List_To_Search := Sinfo.Declarations (Scope); 261 else 262 List_To_Search := Visible_Declarations (Scope); 263 end if; 264 265 Result := Find_In_List (List_To_Search); 266 267 if No (Result) then 268 269 if Nkind (Scope) = N_Package_Specification then 270 List_To_Search := Private_Declarations (Scope); 271 Result := Find_In_List (List_To_Search); 272 273 if No (Result) 274 and then 275 Nkind (Parent (Scope)) = N_Generic_Package_Declaration 276 then 277 List_To_Search := Generic_Formal_Declarations (Parent (Scope)); 278 Result := Find_In_List (List_To_Search); 279 end if; 280 281 elsif Nkind (Scope) = N_Block_Statement 282 or else 283 Nkind (Scope) = N_Subprogram_Body 284 then 285 -- We can have an instantiation nested in some block statement in 286 -- tne library subprogram body. This should not happen too often, 287 -- so we can use this performance-expensive approach here. 288 Traverse_Scope (Scope); 289 end if; 290 291 end if; 292 293 pragma Assert (Present (Result)); 294 295 return Result; 296 297 end Find_Enclosed_Decl; 298 299 ------------------- 300 -- Get_Tree_Name -- 301 ------------------- 302 303 function Get_Tree_Name (C : Context_Id; Id : Tree_Id) return String is 304 begin 305 Get_Name_String (C, Id); 306 return A_Name_Buffer (1 .. A_Name_Len); 307 end Get_Tree_Name; 308 309 ----------------------------- 310 -- Restore_Node_From_Trace -- 311 ----------------------------- 312 313 function Restore_Node_From_Trace 314 (In_Body : Boolean := False; 315 CU : Asis.Compilation_Unit := Asis.Nil_Compilation_Unit) 316 return Node_Id 317 is 318 Start_Node : Node_Id; 319 Result : Node_Id := Empty; 320 begin 321 322 if Asis.Compilation_Units.Is_Nil (CU) then 323 Start_Node := Unit (Cunit (Main_Unit)); 324 325 if Nkind (Start_Node) = N_Package_Body and then 326 not In_Body 327 then 328 Start_Node := Corresponding_Spec (Start_Node); 329 330 while not (Nkind (Start_Node) = N_Package_Declaration 331 or else 332 Nkind (Start_Node) = N_Generic_Package_Declaration) 333 loop 334 Start_Node := Parent (Start_Node); 335 end loop; 336 337 end if; 338 else 339 Start_Node := Unit (Top (CU)); 340 end if; 341 342 if Node_Trace.First = Node_Trace.Last then 343 -- One-element trace means, that we have a library-level package 344 -- instantiation 345 Result := Start_Node; 346 else 347 348 if Nkind (Start_Node) = N_Package_Declaration 349 or else 350 Nkind (Start_Node) = N_Generic_Package_Declaration 351 then 352 Start_Node := Specification (Start_Node); 353 end if; 354 355 for J in reverse Node_Trace.First + 1 .. Node_Trace.Last - 1 loop 356 Start_Node := Find_Enclosed_Decl (Start_Node, J); 357 358 if Nkind (Start_Node) = N_Package_Declaration 359 or else 360 Nkind (Start_Node) = N_Generic_Package_Declaration 361 then 362 Start_Node := Specification (Start_Node); 363 end if; 364 365 end loop; 366 367 Result := Find_Enclosed_Decl (Start_Node, Node_Trace.First); 368 369 end if; 370 371 pragma Assert (Present (Result)); 372 373 return Result; 374 375 end Restore_Node_From_Trace; 376 377 --------------------- 378 -- Get_Name_String -- 379 --------------------- 380 381 procedure Get_Name_String (C : Context_Id; Id : Tree_Id) is 382 S : Int; 383 L : Short; 384 385 begin 386 387 Reset_Context (C); -- ??? 388 389 S := Tree_Table.Table (Id).Tree_Name_Chars_Index; 390 L := Tree_Table.Table (Id).Tree_Name_Len; 391 392 A_Name_Len := Natural (L); 393 394 for I in 1 .. A_Name_Len loop 395 A_Name_Buffer (I) := A_Name_Chars.Table (S + Int (I)); 396 end loop; 397 end Get_Name_String; 398 399 ----------------- 400 -- Print_Trees -- 401 ----------------- 402 procedure Print_Trees (C : Context_Id) is 403 begin 404 Write_Str ("Tree Table for Context number: "); 405 Write_Int (Int (C)); 406 Write_Eol; 407 408 if C = Non_Associated then 409 Write_Str (" Nil Context, it can never be associated "); 410 Write_Str ("with any tree"); 411 Write_Eol; 412 return; 413 end if; 414 415 if Is_Opened (C) then 416 for Tr in First_Tree_Id .. Last_Tree (C) loop 417 Output_Tree (C, Tr); 418 end loop; 419 Write_Eol; 420 else 421 Write_Str ("This Context is closed"); 422 Write_Eol; 423 end if; 424 end Print_Trees; 425 426 ----------------------------- 427 -- Set_Nil_Tree_Attributes -- 428 ----------------------------- 429 430 procedure Set_Nil_Tree_Attributes (T : Tree_Id) is 431 begin 432 Set_Main_Unit_Id (T, Nil_Unit); 433 Set_Main_Top (T, Empty); 434 Tree_Table.Table (T).Units := No_Elist; 435 end Set_Nil_Tree_Attributes; 436 437 ------------------------ 438 -- Set_Nil_Tree_Names -- 439 ------------------------ 440 441 procedure Set_Nil_Tree_Names (T : Tree_Id) is 442 Tr : constant Tree_Id := T; 443 begin 444 Tree_Table.Table (Tr).Tree_Name_Chars_Index := 0; 445 Tree_Table.Table (Tr).Tree_Name_Len := 0; 446 end Set_Nil_Tree_Names; 447 448 --------------------------------------------------------------- 449 -- Internal Tree Unit Attributes Access and Update Routines -- 450 --------------------------------------------------------------- 451 452 function Main_Unit_Id (T : Tree_Id) return Unit_Id is 453 begin 454 return Tree_Table.Table (T).Main_Unit; 455 end Main_Unit_Id; 456 457 function Main_Unit_Id return Unit_Id is 458 begin 459 return Tree_Table.Table (Current_Tree).Main_Unit; 460 end Main_Unit_Id; 461 462 procedure Set_Main_Unit_Id (T : Tree_Id; U : Unit_Id) is 463 begin 464 Tree_Table.Table (T).Main_Unit := U; 465 end Set_Main_Unit_Id; 466 467 procedure Set_Main_Top (T : Tree_Id; N : Node_Id) is 468 begin 469 Tree_Table.Table (T).Main_Top := N; 470 end Set_Main_Top; 471 472 procedure Set_Main_Unit_Id (U : Unit_Id) is 473 begin 474 Tree_Table.Table (Current_Tree).Main_Unit := U; 475 end Set_Main_Unit_Id; 476 477 procedure Set_Main_Top (N : Node_Id) is 478 begin 479 Tree_Table.Table (Current_Tree).Main_Top := N; 480 end Set_Main_Top; 481 482 ----------------------------------- 483 -- Subprograms for Tree Swapping -- 484 ----------------------------------- 485 486 ----------------------------------- 487 -- Append_Full_View_Tree_To_Unit -- 488 ----------------------------------- 489 490 procedure Append_Full_View_Tree_To_Unit (C : Context_Id; U : Unit_Id) is 491 begin 492 Reset_Context (C); 493 Add_To_Elmt_List (Unit_Id (Current_Tree), 494 Unit_Table.Table (U).Full_View_Trees); 495 end Append_Full_View_Tree_To_Unit; 496 497 -------------------------------------- 498 -- Append_Limited_View_Tree_To_Unit -- 499 -------------------------------------- 500 501 procedure Append_Limited_View_Tree_To_Unit (C : Context_Id; U : Unit_Id) is 502 begin 503 Reset_Context (C); 504 Add_To_Elmt_List (Unit_Id (Current_Tree), 505 Unit_Table.Table (U).Limited_View_Trees); 506 end Append_Limited_View_Tree_To_Unit; 507 508 ------------------- 509 -- Reorder_Trees -- 510 ------------------- 511 512 procedure Reorder_Trees (C : Context_Id) is 513 Main_Unit : Unit_Id; 514 -- The unit which main tree should be moved to the first position in 515 -- the list of trees for the unit being processed in a loop 516 517 First_Tree : Tree_Id; 518 Success : Boolean; 519 C_Mode : constant Context_Mode := Context_Processing_Mode (C); 520 begin 521 522 for U in First_Unit_Id + 1 .. Last_Unit loop 523 -- First_Unit_Id corresponds to Standard 524 525 Success := True; 526 Main_Unit := Nil_Unit; 527 528 case Kind (C, U) is 529 when A_Subunit => 530 -- (1) 531 Main_Unit := Get_Subunit_Parent_Body (C, U); 532 533 while Kind (C, Main_Unit) in A_Subunit loop 534 Main_Unit := Get_Subunit_Parent_Body (C, Main_Unit); 535 end loop; 536 537 if No (Main_Tree (C, Main_Unit)) then 538 539 if C_Mode in Partition | All_Trees then 540 Get_Name_String (U, Ada_Name); 541 542 ASIS_Warning 543 (Message => 544 "Asis.Ada_Environments.Open: " & 545 "ancestor body is not compiled for subunit " & 546 A_Name_Buffer (1 .. A_Name_Len), 547 Error => Data_Error); 548 end if; 549 550 Success := False; 551 end if; 552 553 when A_Package | 554 A_Generic_Package | 555 A_Procedure | 556 A_Function | 557 A_Generic_Procedure | 558 A_Generic_Function => 559 560 -- (2), (3) and (5) 561 562 if Is_Body_Required (C, U) or else 563 Kind (C, U) = A_Procedure or else 564 Kind (C, U) = A_Function or else 565 Kind (C, U) = A_Generic_Procedure or else 566 Kind (C, U) = A_Generic_Function 567 then 568 -- (2) and (5) 569 Main_Unit := Get_Body (C, U); 570 571 if No (Main_Unit) or else 572 No (Main_Tree (C, Main_Unit)) 573 then 574 -- The second condition corresponds to the situation when 575 -- the tree is created for library-level generic spec 576 -- which requires the body 577 578 if C_Mode in Partition | All_Trees and then 579 Origin (C, U) = An_Application_Unit 580 then 581 Get_Name_String (U, Ada_Name); 582 583 ASIS_Warning 584 (Message => 585 "Asis.Ada_Environments.Open: " 586 & "body is not compiled for " 587 & A_Name_Buffer (1 .. A_Name_Len), 588 Error => Data_Error); 589 end if; 590 591 Success := False; 592 end if; 593 594 else 595 -- (3) 596 Main_Unit := U; 597 598 if No (Main_Tree (C, Main_Unit)) then 599 -- We do not generate any warning in this case, because 600 -- we do not know whether or not this package 601 -- declaration has to be compiled on its own. So we only 602 -- set Success OFF to prevent any change in the tree 603 -- list 604 Success := False; 605 end if; 606 607 end if; 608 609 when A_Generic_Unit_Instance => 610 -- (4) 611 Main_Unit := U; 612 613 if No (Main_Tree (C, Main_Unit)) then 614 615 if C_Mode in Partition | All_Trees and then 616 Origin (C, U) = An_Application_Unit 617 then 618 Get_Name_String (U, Ada_Name); 619 620 ASIS_Warning 621 (Message => 622 "Asis.Ada_Environments.Open: " 623 & "library-level instance " 624 & A_Name_Buffer (1 .. A_Name_Len) 625 & " is not compiled", 626 Error => Data_Error); 627 end if; 628 629 Success := False; 630 end if; 631 632 when A_Library_Unit_Body => 633 -- There are some situations when the body is compiled because 634 -- the corresponding spec is a supporter of the main unit of 635 -- the compilation. See Lib (spec), (h) 636 Main_Unit := U; 637 638 if No (Main_Tree (C, Main_Unit)) then 639 -- We do notr generate a warning here - if needed, the 640 -- warning is generated for the corresponding spec 641 Success := False; 642 end if; 643 644 when others => 645 null; 646 end case; 647 648 if Success and then Present (Main_Unit) then 649 -- Here we have to reorder the trees for U. Currently the 650 -- simplest solution is used - we just prepend the right tree 651 -- to the tree list, if it is not already the first tree in 652 -- the list. So this tree may be duplicated in the list. 653 First_Tree := Main_Tree (C, Main_Unit); 654 655 if First_Tree /= 656 Tree_Id 657 (Unit (First_Elmt (Unit_Table.Table (U).Full_View_Trees))) 658 then 659 Prepend_Elmt 660 (Unit_Id (First_Tree), Unit_Table.Table (U).Full_View_Trees); 661 end if; 662 663 end if; 664 665 end loop; 666 667 end Reorder_Trees; 668 669 ---------------- 670 -- Reset_Tree -- 671 ---------------- 672 673 procedure Reset_Tree (Context : Context_Id; Tree : Tree_Id) is 674 Tree_File_FD : File_Descriptor; 675 File_Closed : Boolean := False; 676 begin 677 -- Special processing for GNSA mode: 678 679 if Tree_Processing_Mode (Current_Context) = GNSA then 680 -- This is no more than a workaround for -GNSA C1 Context when we 681 -- have exactly one tree (and exactly one (GNSA) Context! 682 return; 683 end if; 684 685 if Context = Current_Context and then 686 Tree = Current_Tree 687 then 688 return; 689 end if; 690 691 if Debug_Flag_T then 692 Write_Str ("In Context "); 693 Write_Int (Int (Context)); 694 Write_Str (" resetting the tree "); 695 Write_Int (Int (Tree)); 696 Write_Eol; 697 end if; 698 699 -- the following call to Reset_Context is redundant, because the next 700 -- call to Get_Name_String also resets Context, but this is the right 701 -- place for Reset_Context 702 Reset_Context (Context); 703 704 Get_Name_String (Context, Tree); 705 -- should be always successful, because Tree may correspond only to 706 -- some tree file, which has been investigated by ASIS 707 708 A_Name_Buffer (A_Name_Len + 1) := ASCII.NUL; 709 710 if Debug_Flag_T then 711 Write_Str (" ("); 712 Write_Str (A_Name_Buffer (1 .. A_Name_Len)); 713 Write_Str (")"); 714 Write_Eol; 715 716 end if; 717 718 Tree_File_FD := Open_Read (A_Name_Buffer'Address, Binary); 719 720 if Tree_File_FD = Invalid_FD then 721 Raise_ASIS_Failed 722 (Diagnosis => "A4G.Contt.TT.Reset_Tree: " & 723 "Cannot open tree file: " & 724 A_Name_Buffer (1 .. A_Name_Len) & 725 ASIS_Line_Terminator & 726 "ASIS external environment may have been changed", 727 Stat => Data_Error); 728 end if; 729 730 begin 731 Tree_In (Tree_File_FD); 732 exception 733 when others => 734 Close (Tree_File_FD, File_Closed); 735 736 -- We did not chech File_Closed here, because the problem in 737 -- Tree_In seems to be more important for ASIS 738 739 Raise_ASIS_Failed 740 (Diagnosis => "A4G.Contt.TT.Reset_Tree: " & 741 "Can not read tree file: " & 742 A_Name_Buffer (1 .. A_Name_Len) & 743 ASIS_Line_Terminator & 744 "ASIS external environment may have been changed", 745 Stat => Data_Error); 746 end; 747 748 Close (Tree_File_FD, File_Closed); 749 750 if not File_Closed then 751 Raise_ASIS_Failed 752 (Diagnosis => "A4G.Contt.TT.Reset_Tree: " & 753 "Can not close tree file: " & 754 A_Name_Buffer (1 .. A_Name_Len) & 755 ASIS_Line_Terminator & 756 "disk is full or file may be used by other program", 757 Stat => Data_Error); 758 end if; 759 760 -- if we are here, then the required tree has been successfully 761 -- re-retrieved. So: 762 763 Current_Context := Context; 764 Current_Tree := Tree; 765 766 if Debug_Flag_T then 767 Write_Str ("In Context "); 768 Write_Int (Int (Context)); 769 Write_Str (" the tree "); 770 Write_Int (Int (Tree)); 771 Write_Str (" has been reset"); 772 Write_Eol; 773 end if; 774 775 end Reset_Tree; 776 777 ----------------------------- 778 -- Reset_Tree_For_Element -- 779 ----------------------------- 780 781 procedure Reset_Tree_For_Element (E : Asis.Element) is 782 begin 783 Reset_Tree (Encl_Cont_Id (E), Encl_Tree (E)); 784 end Reset_Tree_For_Element; 785 786 ------------------------- 787 -- Reset_Tree_For_Unit -- 788 ------------------------- 789 790 procedure Reset_Tree_For_Unit (C : Context_Id; U : Unit_Id) is 791 Tree_List : Elist_Id; 792 Tree_To_Set : Tree_Id; 793 begin 794 -- Special processing for GNSA mode: 795 796 if Tree_Processing_Mode (Get_Current_Cont) = GNSA then 797 -- This is no more than a workaround for -GNSA C1 Context when we 798 -- have exactly one tree (and exactly one (GNSA) Context! 799 return; 800 end if; 801 802 Tree_List := Unit_Table.Table (U).Full_View_Trees; 803 804 if No (Tree_List) or else No (First_Elmt (Tree_List)) then 805 Tree_List := Unit_Table.Table (U).Limited_View_Trees; 806 end if; 807 -- it cannot be No_List or Empty_List! 808 809 Tree_To_Set := Tree_Id (Unit (First_Elmt (Tree_List))); 810 811 if Debug_Flag_T then 812 Write_Str ("For unit "); 813 Write_Int (Int (U)); 814 Write_Str (" "); 815 end if; 816 817 Reset_Tree (Context => C, 818 Tree => Tree_To_Set); 819 end Reset_Tree_For_Unit; 820 821 procedure Reset_Tree_For_Unit (Unit : Asis.Compilation_Unit) is 822 begin 823 Reset_Tree_For_Unit (Encl_Cont_Id (Unit), Get_Unit_Id (Unit)); 824 end Reset_Tree_For_Unit; 825 826 ------------------------- 827 -- Reset_Instance_Tree -- 828 ------------------------- 829 830 procedure Reset_Instance_Tree 831 (Lib_Level_Instance : Asis.Compilation_Unit; 832 Decl_Node : in out Node_Id) 833 is 834 U : Unit_Id := Get_Unit_Id (Lib_Level_Instance); 835 Tree_To_Set : Tree_Id; 836 Curr_Context : constant Context_Id := Get_Current_Cont; 837 Curr_Tree : constant Tree_Id := Get_Current_Tree; 838 In_Body : Boolean := False; 839 begin 840 -- Special processing for GNSA mode: 841 842 if Tree_Processing_Mode (Curr_Context) = GNSA then 843 -- This is no more than a workaround for -GNSA C1 Context when we 844 -- have exactly one tree (and exactly one (GNSA) Context! 845 return; 846 end if; 847 848 Tree_To_Set := 849 Unit_Table.Table (U).Main_Tree; 850 851 if No (Tree_To_Set) then 852 853 if Kind (Lib_Level_Instance) in A_Package .. A_Generic_Package or else 854 Kind (Lib_Level_Instance) in A_Library_Unit_Body 855 then 856 U := Get_Body (Current_Context, U); 857 858 if Tree_Processing_Mode (Curr_Context) = Incremental and then 859 (No (U) or else 860 No (Unit_Table.Table (U).Main_Tree)) 861 then 862 -- In this situation we try to compile the needed body on the 863 -- fly 864 if Is_Body_Required (Lib_Level_Instance) or else 865 Kind (Lib_Level_Instance) in A_Library_Unit_Body 866 then 867 868 U := Get_Main_Unit_Tree_On_The_Fly 869 (Start_Unit => Get_Unit_Id (Lib_Level_Instance), 870 Cont => Curr_Context, 871 Spec => False); 872 else 873 U := Get_Main_Unit_Tree_On_The_Fly 874 (Start_Unit => Get_Unit_Id (Lib_Level_Instance), 875 Cont => Curr_Context, 876 Spec => True); 877 end if; 878 879 end if; 880 881 elsif Kind (Lib_Level_Instance) in A_Generic_Unit_Instance and then 882 Tree_Processing_Mode (Encl_Cont_Id (Lib_Level_Instance)) = 883 Incremental 884 then 885 U := Get_Main_Unit_Tree_On_The_Fly 886 (Start_Unit => Get_Unit_Id (Lib_Level_Instance), 887 Cont => Curr_Context, 888 Spec => True); 889 end if; 890 891 if Present (U) then 892 893 Tree_To_Set := Unit_Table.Table (U).Main_Tree; 894 895 Reset_Tree (Context => Get_Current_Cont, 896 Tree => Curr_Tree); 897 end if; 898 899 end if; 900 901 if No (Tree_To_Set) or else Tree_To_Set = Current_Tree then 902 return; 903 end if; 904 905 Create_Node_Trace (Decl_Node); 906 907 Reset_Tree (Context => Get_Current_Cont, 908 Tree => Tree_To_Set); 909 910 if Kind (Lib_Level_Instance) in A_Library_Unit_Body then 911 In_Body := True; 912 end if; 913 914 Decl_Node := Restore_Node_From_Trace (In_Body); 915 916 end Reset_Instance_Tree; 917 918 ---------------------------------- 919 -- Tree_Consistent_With_Sources -- 920 ---------------------------------- 921 922 function Tree_Consistent_With_Sources 923 (E : Asis.Element) 924 return Boolean 925 is 926 begin 927 928 Reset_Tree (Encl_Cont_Id (E), Encl_Tree (E)); 929 930 return Current_Tree_Consistent_With_Sources; 931 932 end Tree_Consistent_With_Sources; 933 934 function Tree_Consistent_With_Sources 935 (CU : Asis.Compilation_Unit) 936 return Boolean 937 is 938 begin 939 Reset_Tree_For_Unit (CU); 940 return Current_Tree_Consistent_With_Sources; 941 end Tree_Consistent_With_Sources; 942 943 -------------------------- 944 -- Unit_In_Current_Tree -- 945 -------------------------- 946 947 function Unit_In_Current_Tree (C : Context_Id; U : Unit_Id) return Boolean 948 is 949 begin 950 if U = Standard_Id then 951 return True; 952 end if; 953 954 if Current_Context /= C then 955 return False; 956 end if; 957 958 return 959 In_Elmt_List 960 (Unit_Id (Current_Tree), Unit_Table.Table (U).Full_View_Trees) 961 or else 962 (No (Unit_Table.Table (U).Full_View_Trees) 963 and then 964 In_Elmt_List 965 (Unit_Id (Current_Tree), Unit_Table.Table (U).Limited_View_Trees)); 966 967 end Unit_In_Current_Tree; 968 969-------------------------------------------------- 970-- General-Purpose Tree Table Subprograms -- 971-------------------------------------------------- 972 973 --------------- 974 -- Last_Tree -- 975 --------------- 976 977 function Last_Tree (C : Context_Id) return Tree_Id is 978 begin 979 Reset_Context (C); 980 return Tree_Table.Last; 981 end Last_Tree; 982 983 -------- 984 -- No -- 985 -------- 986 987 function No (Tree : Tree_Id) return Boolean is 988 begin 989 return Tree = Nil_Tree; 990 end No; 991 992 ----------------- 993 -- Output_Tree -- 994 ----------------- 995 996 procedure Output_Tree (C : Context_Id; Tree : Tree_Id) is 997 begin 998 999 -- ??? Check for Debug_Mode should be moved into the context(s) where 1000 -- ??? Output_Tree is called 1001 1002 if Debug_Mode or else 1003 Debug_Flag_C or else 1004 Debug_Lib_Model 1005 then 1006 Write_Str ("Debug output for Tree Id " & Tree_Id'Image (Tree)); 1007 Write_Eol; 1008 1009 if Tree = Nil_Tree then 1010 Write_Str ("This is a Nil Tree"); 1011 Write_Eol; 1012 return; 1013 end if; 1014 1015 Get_Name_String (C, Tree); 1016 1017 Write_Str ("Tree File Name is: " & A_Name_Buffer (1 .. A_Name_Len)); 1018 Write_Eol; 1019 1020 Write_Str ("Main Unit Id : "); 1021 Write_Str (Main_Unit_Id (Tree)'Img); 1022 Write_Eol; 1023 1024 Write_Str ("The list of the Units contained in the tree:"); 1025 Write_Eol; 1026 1027 Print_List (Tree_Table.Table (Tree).Units); 1028 1029 Write_Eol; 1030 end if; 1031 1032 end Output_Tree; 1033 1034 ------------- 1035 -- Present -- 1036 ------------- 1037 1038 function Present (Tree : Tree_Id) return Boolean is 1039 begin 1040 return Tree /= No_Tree_Name; 1041 end Present; 1042 1043end A4G.Contt.TT; 1044