------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . C O N T T . T T                         --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.35 $
--                                                                          --
--            Copyright (c) 1995-2002, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

--  This package defines Tree Table, which contains the information
--  about the tree output files needed for swapping the ASTs accessed
--  by ASIS. This information includes such things as Asis Compilation
--  Units, and their top nodes in the tree.

with Asis;            use Asis;
with Asis.Errors;     use Asis.Errors;
with Asis.Exceptions; use Asis.Exceptions;

with Asis.Set_Get;    use Asis.Set_Get;
with A4G.A_Debug;     use A4G.A_Debug;
with A4G.A_Output;    use A4G.A_Output;
with A4G.Vcheck;      use A4G.Vcheck;
with A4G.Contt.UT;    use A4G.Contt.UT;
with A4G.Asis_Tables; use A4G.Asis_Tables;
with A4G.Get_Unit;    use A4G.Get_Unit;

with Types;           use Types;
with Lib;             use Lib;
with Atree;           use Atree;
with Sinfo;           use Sinfo;
with Nlists;          use Nlists;
with Sinput;          use Sinput;
with Namet;           use Namet;
with Output;          use Output;
with Tree_In;

package body A4G.Contt.TT is

   procedure Set_Nil_Tree_Names (T : Tree_Id);
   --  Sets all the fields related to Source File Name Table as indicating
   --  empty  strings

   procedure Set_Nil_Tree_Attributes (T : Tree_Id);
   --  Sets all the attributes of T as if T is an ASIS Nil_Tree

   function Restore_Node_From_Trace
     (In_Body : Boolean := False)
      return    Node_Id;
   --  Taking the node trace stored in Node_Trace table, tries to find the
   --  construct corresponding to the beginning of the trace in the currently
   --  accessed tree. By default we consider that we are in the package spec,
   --  unless In_Body is set ON.

   function Find_Enclosed_Decl
     (Scope : Node_Id;
      J         : Int)
      return Node_Id;
   --  Starting from Scope, looks for the nested scope which is stored
   --  in Node_Trace table as Node_Trase.Table (J). Node, that expanded
   --  generic specs are considered as ordinary scopes.

   -------------------------
   -- Allocate_Tree_Entry --
   -------------------------

   function Allocate_Tree_Entry return Tree_Id is
      New_Last : Tree_Id;
      --  the Id of the new entry being allocated in the Unit Table
   begin

      Tree_Table.Increment_Last;
      New_Last := Tree_Table.Last;

      Set_Nil_Tree_Names      (New_Last);
      Set_Nil_Tree_Attributes (New_Last);

      Tree_Table.Table (New_Last).Tree_Name_Chars_Index := A_Name_Chars.Last;

      Tree_Table.Table (New_Last).Tree_Name_Len := Short (A_Name_Len);

      --  Set corresponding string entry in the Name_Chars table

      for I in 1 .. A_Name_Len loop
         A_Name_Chars.Increment_Last;

         A_Name_Chars.Table (A_Name_Chars.Last) := A_Name_Buffer (I);
      end loop;

      A_Name_Chars.Increment_Last;
      A_Name_Chars.Table (A_Name_Chars.Last) := ASCII.NUL;
      return New_Last;

   end Allocate_Tree_Entry;

   ------------------------------------------
   -- Current_Tree_Consistent_With_Sources --
   ------------------------------------------

   function Current_Tree_Consistent_With_Sources return Boolean is
      Result       : Boolean := True;
      Source_Stamp : Time_Stamp_Type;
      Tree_Stamp   : Time_Stamp_Type;
      Source       : File_Name_Type;
   begin

      for J in 2 .. Last_Source_File loop
         --  We start from 2, because the entry 1 in the Source File Table
         --  is always for system.ads (see Sinput, spec).
         Tree_Stamp := Time_Stamp (J);

         Source := Full_File_Name (J);

         Get_Name_String (Source);
         Name_Len := Name_Len + 1;
         Name_Buffer (Name_Len) := ASCII.NUL;

         if not Is_Regular_File (Name_Buffer) then
            --  The source file was (re)moved
            Result := False;
            exit;

         else
            Source_Stamp := TS_From_OS_Time (File_Time_Stamp (Name_Buffer));

            if Source_Stamp /= Tree_Stamp then
               --  The source file has been changed
               Result := False;
               exit;
            end if;

         end if;

      end loop;

      return Result;

   end Current_Tree_Consistent_With_Sources;

   ------------------------
   -- Find_Enclosed_Decl --
   ------------------------

   function Find_Enclosed_Decl
     (Scope : Node_Id;
      J     : Int)
      return Node_Id
   is
      Result : Node_Id := Empty;

      List_To_Search : List_Id;
      Kind_To_Search : Node_Kind            := Node_Trace.Table (J).Kind;
      Line_To_Search : Physical_Line_Number := Node_Trace.Table (J).Node_Line;
      Col_To_Search  : Column_Number        := Node_Trace.Table (J).Node_Col;

      function Find_In_List (L : List_Id) return Node_Id;
      --  Looks for the needed scope in a node list

      function Find_In_List (L : List_Id) return Node_Id is
         Res       : Node_Id := Empty;
         Next_Node : Node_Id;
         Next_Sloc : Source_Ptr;
      begin
         Next_Node := First_Non_Pragma (L);

         while Present (Next_Node) loop

            if Nkind (Next_Node) = Kind_To_Search then
               Next_Sloc := Sloc (Next_Node);

               if Get_Physical_Line_Number (Next_Sloc) = Line_To_Search
                 and then
                  Get_Column_Number (Next_Sloc)        = Col_To_Search
               then
                  Res := Next_Node;
                  exit;
               end if;


            end if;

            Next_Node := Next_Non_Pragma (Next_Node);

         end loop;

         return Res;
      end Find_In_List;

   begin

      if Nkind (Scope) = N_Package_Instantiation then
         Result := Scope;

         while Nkind (Result) /= N_Package_Declaration loop
            Result := Prev_Non_Pragma (Result);
         end loop;

         return Result;

      end if;

      if Nkind (Scope) = N_Package_Body then
         List_To_Search := Sinfo.Declarations (Scope);
      else
         List_To_Search := Visible_Declarations (Scope);
      end if;

      Result := Find_In_List (List_To_Search);

      if No (Result) and then
         Nkind (Scope) = N_Package_Specification
      then
         List_To_Search := Private_Declarations (Scope);
         Result := Find_In_List (List_To_Search);
      end if;

      pragma Assert (Present (Result));

      return Result;

   end Find_Enclosed_Decl;

   -----------------------------
   -- Restore_Node_From_Trace --
   -----------------------------

   function Restore_Node_From_Trace
     (In_Body : Boolean := False)
      return    Node_Id
   is
      Start_Node : Node_Id;
      Result     : Node_Id := Empty;
   begin

      Start_Node := Unit (Cunit (Main_Unit));

      if Nkind (Start_Node) = N_Package_Body and then
         not In_Body
      then
         Start_Node := Corresponding_Spec (Start_Node);

         while Nkind (Start_Node) /= N_Package_Declaration loop
            Start_Node := Parent (Start_Node);
         end loop;

      end if;

      if Node_Trace.First = Node_Trace.Last then
         --  One-element trace means, that we have a library-level package
         --  instantiation
         Result := Start_Node;
      else

         if Nkind (Start_Node) = N_Package_Declaration then
            Start_Node := Specification (Start_Node);
         end if;

         for J in reverse Node_Trace.First + 1 .. Node_Trace.Last - 1 loop
            Start_Node := Find_Enclosed_Decl (Start_Node, J);

            if Nkind (Start_Node) = N_Package_Declaration then
               Start_Node := Specification (Start_Node);
            end if;

         end loop;

         Result := Find_Enclosed_Decl (Start_Node, Node_Trace.First);

      end if;

      pragma Assert (Present (Result));

      return Result;

   end Restore_Node_From_Trace;

   ---------------------
   -- Get_Name_String --
   ---------------------

   procedure Get_Name_String (C : Context_Id; Id : Tree_Id) is
      S : Int;
      L : Short;

   begin

      Reset_Context (C); --  ???

      S := Tree_Table.Table (Id).Tree_Name_Chars_Index;
      L := Tree_Table.Table (Id).Tree_Name_Len;

      A_Name_Len := Natural (L);

      for I in 1 .. A_Name_Len loop
         A_Name_Buffer (I) := A_Name_Chars.Table (S + Int (I));
      end loop;
   end Get_Name_String;

   -----------------
   -- Print_Trees --
   -----------------
   procedure Print_Trees (C : Context_Id) is
   begin
      Write_Str ("Tree Table for Context number: ");
      Write_Int (Int (C));
      Write_Eol;

      if C = Non_Associated then
         Write_Str ("   Nil Context, it can never be associated ");
         Write_Str ("with any tree");
         Write_Eol;
         return;
      end if;

      if Is_Opened (C) then
         for Tr in First_Tree_Id .. Last_Tree (C) loop
            Output_Tree (C, Tr);
         end loop;
         Write_Eol;
      else
         Write_Str ("This Context is closed");
         Write_Eol;
      end if;
   end Print_Trees;

   -----------------------------
   -- Set_Nil_Tree_Attributes --
   -----------------------------

   procedure Set_Nil_Tree_Attributes (T : Tree_Id) is
   begin
      Set_Main_Unit_Id (T, Nil_Unit);
      Set_Main_Top (T, Empty);
      Tree_Table.Table (T).Units := No_Elist;
   end Set_Nil_Tree_Attributes;

   ------------------------
   -- Set_Nil_Tree_Names --
   ------------------------

   procedure Set_Nil_Tree_Names (T : Tree_Id) is
      Tr : constant Tree_Id := T;
   begin
      Tree_Table.Table (Tr).Tree_Name_Chars_Index := 0;
      Tree_Table.Table (Tr).Tree_Name_Len         := 0;
   end Set_Nil_Tree_Names;


   ---------------------------------------------------------------
   --  Internal Tree Unit Attributes Access and Update Routines --
   ---------------------------------------------------------------

   function Main_Unit_Id (T : Tree_Id) return Unit_Id is
   begin
      return Tree_Table.Table (T).Main_Unit;
   end Main_Unit_Id;

   function Main_Unit_Id return Unit_Id is
   begin
      return Tree_Table.Table (Current_Tree).Main_Unit;
   end Main_Unit_Id;


   procedure Set_Main_Unit_Id (T : Tree_Id; U : Unit_Id) is
   begin
      Tree_Table.Table (T).Main_Unit := U;
   end Set_Main_Unit_Id;

   procedure Set_Main_Top  (T : Tree_Id; N : Node_Id) is
   begin
      Tree_Table.Table (T).Main_Top := N;
   end Set_Main_Top;

   procedure Set_Main_Unit_Id (U : Unit_Id) is
   begin
      Tree_Table.Table (Current_Tree).Main_Unit := U;
   end Set_Main_Unit_Id;

   procedure Set_Main_Top  (N : Node_Id) is
   begin
      Tree_Table.Table (Current_Tree).Main_Top := N;
   end Set_Main_Top;

   -----------------------------------
   -- Subprograms for Tree Swapping --
   -----------------------------------

   -------------------------
   -- Append_Tree_To_Unit --
   -------------------------

   procedure Append_Tree_To_Unit (C : Context_Id; U : Unit_Id) is
   begin
      Reset_Context (C);
      Add_To_Elmt_List (Unit_Id (Current_Tree),
                        Unit_Table.Table (U).Trees);
   end Append_Tree_To_Unit;

   -------------------
   -- Reorder_Trees --
   -------------------

   procedure Reorder_Trees (C : Context_Id) is
      Main_Unit : Unit_Id;
      --  The unit which main tree should be moved to the first position in
      --  the list of trees for the unit being processed in a loop
      First_Tree : Tree_Id;

      Success : Boolean;

      C_Mode  : Context_Mode := Context_Processing_Mode (C);
   begin

      for U in First_Unit_Id + 1 .. Last_Unit loop
         --  First_Unit_Id corresponds to Standard

         Success   := True;
         Main_Unit := Nil_Unit;

         case Kind (C, U) is
            when A_Subunit =>
               --  (1)
               Main_Unit := Get_Subunit_Parent_Body (C, U);

               while Kind (C, Main_Unit) in A_Subunit loop
                  Main_Unit := Get_Subunit_Parent_Body (C, Main_Unit);
               end loop;

               if No (Main_Tree (C, Main_Unit)) then

                  if C_Mode in Partition .. All_Trees then
                     Get_Name_String (U, Ada_Name);

                     ASIS_Warning
                        (Message =>
                           "Asis.Ada_Environments.Open: " &
                           "ancestor body is not compiled for subunit " &
                            A_Name_Buffer (1 .. A_Name_Len),
                         Error   => Data_Error);
                  end if;

                  Success := False;
               end if;

            when A_Package           |
                 A_Generic_Package   |
                 A_Procedure         |
                 A_Function          |
                 A_Generic_Procedure |
                 A_Generic_Function  =>

               --  (2), (3) and (5)

               if Is_Body_Required (C, U)           or else
                  Kind (C, U) = A_Procedure         or else
                  Kind (C, U) = A_Function          or else
                  Kind (C, U) = A_Generic_Procedure or else
                  Kind (C, U) = A_Generic_Function
               then
                  --  (2) and (5)
                  Main_Unit := Get_Body (C, U);

                  if No (Main_Unit) or else
                     No (Main_Tree (C, Main_Unit))
                  then
                     --  The second condition corresponds to the situation when
                     --  the tree is created for library-level generic spec
                     --  which requires the body

                     if C_Mode in Partition .. All_Trees and then
                        Origin (C, U) = An_Application_Unit
                     then
                        Get_Name_String (U, Ada_Name);

                        ASIS_Warning
                           (Message =>
                                "Asis.Ada_Environments.Open: "
                              & "body is not compiled for "
                              &  A_Name_Buffer (1 .. A_Name_Len),
                            Error   => Data_Error);
                     end if;

                     Success := False;
                  end if;

               else
                  --  (3)
                  Main_Unit := U;

                  if No (Main_Tree (C, Main_Unit)) then
                     --  We do not generate any warning in this case, because
                     --  we do not know whether or not this package
                     --  declaration has to be compiled on its own. So we only
                     --  set Success OFF to prevent any change in the tree
                     --  list
                     Success := False;
                  end if;

               end if;

            when A_Generic_Unit_Instance =>
               --  (4)
               Main_Unit := U;

               if No (Main_Tree (C, Main_Unit)) then

                  if C_Mode in Partition .. All_Trees and then
                     Origin (C, U) = An_Application_Unit
                  then
                     Get_Name_String (U, Ada_Name);

                     ASIS_Warning
                        (Message =>
                            "Asis.Ada_Environments.Open: "
                          & "library-level instance "
                          &  A_Name_Buffer (1 .. A_Name_Len)
                          & " is not compiled",
                         Error   => Data_Error);
                  end if;

                  Success := False;
               end if;

            when A_Library_Unit_Body =>
               --  There are some situations when the body is compiled because
               --  the corresponding spec is a supporter of the main unit of
               --  the compilation. See Lib (spec), (h)
               Main_Unit := U;

               if No (Main_Tree (C, Main_Unit)) then
                  --  We do notr generate a warning here - if needed, the
                  --  warning is generated for the corresponding spec
                  Success := False;
               end if;

            when others =>
               null;
         end case;

         if Success and then Present (Main_Unit) then
            --  Here we have to reorder the trees for U. Currently the
            --  simplest solution is used - we just prepend the right tree
            --  to the tree list, if it is not already the first tree in
            --  the list. So this tree may be duplicated in the list.
            First_Tree := Main_Tree (C, Main_Unit);

            if First_Tree /=
               Tree_Id (Unit (First_Elmt (Unit_Table.Table (U).Trees)))
            then
               Prepend_Elmt (Unit_Id (First_Tree), Unit_Table.Table (U).Trees);
            end if;

         end if;

      end loop;

   end Reorder_Trees;

   ----------------
   -- Reset_Tree --
   ----------------

   procedure Reset_Tree (Context : Context_Id; Tree : Tree_Id) is
      Tree_File_FD : File_Descriptor;
   begin
      if Context = Current_Context and then
         Tree    = Current_Tree
      then
         return;
      end if;

      if Debug_Flag_T then
         Write_Str ("In Context ");
         Write_Int (Int (Context));
         Write_Str (" resetting the tree ");
         Write_Int (Int (Tree));
         Write_Eol;
      end if;

      --  the following call to Reset_Context is redundant, because the next
      --  call to Get_Name_String also resets Context, but this is the right
      --  place for Reset_Context
      Reset_Context (Context);

      Get_Name_String (Context, Tree);
      --  should be always successful, because Tree may correspond only to
      --  some tree file, which has been investigated by ASIS

      A_Name_Buffer (A_Name_Len + 1) := ASCII.NUL;

      if Debug_Flag_T then
         Write_Str (" (");
         Write_Str (A_Name_Buffer (1 .. A_Name_Len));
         Write_Str (")");
         Write_Eol;

      end if;

      Tree_File_FD := Open_Read (A_Name_Buffer'Address, Binary);

      if Tree_File_FD = Invalid_FD then
         Raise_ASIS_Failed (Diagnosis => "A4G.Contt.TT.Reset_Tree: "
            & "Cannot open tree file: " & A_Name_Buffer (1 .. A_Name_Len)
            & ASIS_Line_Terminator
            & "ASIS external environment may have been changed");
      end if;

      begin
         Tree_In (Tree_File_FD);
         Close   (Tree_File_FD);
      exception
         when others =>
            Close (Tree_File_FD);
            Raise_ASIS_Failed (
               Argument  => Nil_Element,
               Diagnosis =>
                  "A4G.Contt.TT.Reset_Tree: "
                & "Cannot read tree file: " & A_Name_Buffer (1 .. A_Name_Len)
                & ASIS_Line_Terminator
                & "ASIS external environment may have been changed");
      end;

      --  if we are here, then the required tree has been successfully
      --  re-retrieved. So:

      Current_Context := Context;
      Current_Tree    := Tree;

      if Debug_Flag_T then
         Write_Str ("In Context ");
         Write_Int (Int (Context));
         Write_Str (" the tree ");
         Write_Int (Int (Tree));
         Write_Str (" has been reset");
         Write_Eol;
      end if;

   exception
      when ASIS_Failed =>
         Close   (Tree_File_FD);
         Add_Call_Information (
            Argument   => Nil_Element,
            Outer_Call => "A4G.Contt.TT.Reset_Tree");
      when others =>
         Close   (Tree_File_FD);
         Raise_ASIS_Failed (
            Argument  => Nil_Element,
            Diagnosis => "A4G.Contt.TT.Reset_Tree: Failed to reset tree");

   end Reset_Tree;

   -------------------------
   -- Reset_Tree_For_Unit --
   -------------------------

   procedure Reset_Tree_For_Unit (C : Context_Id; U : Unit_Id) is
      Tree_List   : Elist_Id;
      Tree_To_Set : Tree_Id;
   begin
      Tree_List  := Unit_Table.Table (U).Trees;
      --  it cannot be No_List or Empty_List!

      Tree_To_Set := Tree_Id (Unit (First_Elmt (Tree_List)));

      if Debug_Flag_T then
         Write_Str ("For unit ");
         Write_Int (Int (U));
         Write_Str (" ");
      end if;

      Reset_Tree (Context => C,
                  Tree    => Tree_To_Set);
   exception
      when ASIS_Failed =>
         Add_Call_Information (
            Argument   => Nil_Element,
            Outer_Call => "A4G.Contt.TT.Reset_Tree_For_Unit");
         raise;
      when others =>
         Raise_ASIS_Failed (Diagnosis =>
           "A4G.Contt.TT.Reset_Tree_For_Unit: Failed to define tree to reset");
   end Reset_Tree_For_Unit;

   procedure Reset_Tree_For_Unit (Unit : Asis.Compilation_Unit) is
   begin
      Reset_Tree_For_Unit (Encl_Cont_Id (Unit), Get_Unit_Id (Unit));
   end Reset_Tree_For_Unit;

   -------------------------
   -- Reset_Instance_Tree --
   -------------------------

   procedure Reset_Instance_Tree
     (Lib_Level_Instance : Asis.Compilation_Unit;
      Decl_Node          : in out Node_Id)
   is
      U            : Unit_Id := Get_Unit_Id (Lib_Level_Instance);
      Tree_To_Set  : Tree_Id;
      Curr_Context : Context_Id := Get_Current_Cont;
      Curr_Tree    : Tree_Id := Get_Current_Tree;

      In_Body      : Boolean := False;
   begin

      Tree_To_Set :=
         Unit_Table.Table (U).Main_Tree;

      if No (Tree_To_Set) then

         if Kind (Lib_Level_Instance) in A_Package .. A_Generic_Package or else
            Kind (Lib_Level_Instance) in A_Library_Unit_Body
         then
            U := Get_Body (Current_Context, U);

            if Tree_Processing_Mode (Curr_Context) = Incremental and then
               (No (U) or else
                No (Unit_Table.Table (U).Main_Tree))
            then
               --  In this situation we try to compile the needed body on the
               --  fly
               if Is_Body_Required (Lib_Level_Instance) or else
                  Kind (Lib_Level_Instance) in A_Library_Unit_Body
               then

                  U := Get_Main_Unit_Tree_On_The_Fly
                        (Start_Unit => Get_Unit_Id (Lib_Level_Instance),
                        Cont       => Curr_Context,
                        Spec       => False);
               else
                  U := Get_Main_Unit_Tree_On_The_Fly
                        (Start_Unit => Get_Unit_Id (Lib_Level_Instance),
                        Cont       => Curr_Context,
                        Spec       => True);
               end if;

            end if;

         elsif Kind (Lib_Level_Instance) in A_Generic_Unit_Instance and then
               Tree_Processing_Mode (Encl_Cont_Id (Lib_Level_Instance)) =
               Incremental
         then
               U := Get_Main_Unit_Tree_On_The_Fly
                      (Start_Unit => Get_Unit_Id (Lib_Level_Instance),
                       Cont       => Curr_Context,
                       Spec       => True);
         end if;

         if Present (U) then

            Tree_To_Set := Unit_Table.Table (U).Main_Tree;

            Reset_Tree (Context => Get_Current_Cont,
                        Tree    => Curr_Tree);
         end if;

      end if;

      if No (Tree_To_Set) or else Tree_To_Set = Current_Tree then
         return;
      end if;

      Create_Node_Trace (Decl_Node);

      Reset_Tree (Context => Get_Current_Cont,
                  Tree    => Tree_To_Set);

      if Kind (Lib_Level_Instance) in A_Library_Unit_Body then
         In_Body := True;
      end if;

      Decl_Node := Restore_Node_From_Trace (In_Body);

   end Reset_Instance_Tree;

   ----------------------------------
   -- Tree_Consistent_With_Sources --
   ----------------------------------


   function Tree_Consistent_With_Sources
     (E :    Asis.Element)
      return Boolean
   is
   begin

      Reset_Tree (Encl_Cont_Id (E), Encl_Tree (E));

      return Current_Tree_Consistent_With_Sources;

   end Tree_Consistent_With_Sources;

   function Tree_Consistent_With_Sources
     (CU :   Asis.Compilation_Unit)
      return Boolean
   is
   begin
      Reset_Tree_For_Unit (CU);
      return Current_Tree_Consistent_With_Sources;
   end Tree_Consistent_With_Sources;

   --------------------------
   -- Unit_In_Current_Tree --
   --------------------------

   function Unit_In_Current_Tree (C : Context_Id; U : Unit_Id) return Boolean
   is
   begin
      if U = Standard_Id then
         return True;
      end if;

      if Current_Context /= C then
         return False;
      end if;

      return In_Elmt_List (Unit_Id (Current_Tree), Unit_Table.Table (U).Trees);

   end Unit_In_Current_Tree;

--------------------------------------------------
--    General-Purpose Tree Table Subprograms    --
--------------------------------------------------

   ---------------
   -- Last_Tree --
   ---------------

   function Last_Tree (C : Context_Id) return Tree_Id is
   begin
      Reset_Context (C);
      return Tree_Table.Last;
   end Last_Tree;

   --------
   -- No --
   --------

   function No (Tree : Tree_Id) return Boolean is
   begin
      return Tree = Nil_Tree;
   end No;

   -----------------
   -- Output_Tree --
   -----------------

   procedure Output_Tree (C : Context_Id; Tree : Tree_Id) is
   begin

      --  ???  Check for Debug_Mode should be moved into the context(s) where
      --  ???  Output_Tree is called

      if Debug_Mode then
         Write_Str ("Debug output for Tree Id " & Tree_Id'Image (Tree));
         Write_Eol;

         if Tree = Nil_Tree then
            Write_Str ("This is a Nil Tree");
            Write_Eol;
            return;
         end if;

         Get_Name_String (C, Tree);

         Write_Str ("Tree File Name is: " & A_Name_Buffer (1 ..  A_Name_Len));
         Write_Eol;

         Write_Str ("Main Unit Id : ");
         Write_Str (Main_Unit_Id (Tree)'Img);
         Write_Eol;

         Write_Str ("The list of the Units contained in the tree:");
         Write_Eol;

         Print_List (Tree_Table.Table (Tree).Units);

         Write_Eol;
      end if;

   end Output_Tree;

   -------------
   -- Present --
   -------------

   function Present (Tree : Tree_Id) return Boolean is
   begin
      return Tree /= No_Tree_Name;
   end Present;

end A4G.Contt.TT;
