libasis2017-dev 2017-2 / usr / share / ada / adainclude / asis / a4g-contt-dp.adb

------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                         A 4 G . C O N T T . D P                          --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2016, 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 3,  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.                       --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- 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  AdaCore                   --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

pragma Ada_2012;

with Ada.Containers.Ordered_Sets;
with Ada.Unchecked_Deallocation;

with Asis.Set_Get; use Asis.Set_Get;

with A4G.Contt.UT; use A4G.Contt.UT;
with A4G.Get_Unit; use A4G.Get_Unit;

with Atree;        use Atree;
with Nlists;       use Nlists;
with Namet;        use Namet;
with Sinfo;        use Sinfo;
with Lib;          use Lib;

package body A4G.Contt.Dp is

   -----------------------
   -- Local Subprograms --
   -----------------------

   function Get_First_Stub (Body_Node : Node_Id) return Node_Id;
   function Get_Next_Stub  (Stub_Node : Node_Id) return Node_Id;
   --  these two functions implement the iterator through the body stubs
   --  contained in the given compilation unit. The iterator should
   --  be started from calling Get_First_Stub for the node pointed to
   --  the body (that is, for the node of ..._Body kind). The Empty node
   --  is returned if there is no first/next body stub node

   procedure Set_All_Unit_Dependencies (U : Unit_Id);
   --  Computes the full lists of supporters and dependents of U in the current
   --  Context from the list of direct supporters of U and sets these lists as
   --  values of Supporters and Dependents lists in the Unit Table

   procedure Add_Unit_Supporters (U : Unit_Id; L : in out Elist_Id);
   --  Add all the supporters of U, excluding U itself to L. This procedure
   --  traverses all the transitive semantic dependencies.

   procedure Fix_Direct_Supporters (Unit : Unit_Id);
   --  This procedure adds missed direct dependencies to the unit. It is
   --  supposed that before the call the list of direct supporters contains
   --  only units extracted from the unit context clause. So, if U is a body,
   --  this procedure adds the spec to the list of direct supporters, if it is
   --  a subunit - the parent body is added, if it is a child unit - the
   --  parent spec is added etc. The procedure adds these supporters in a
   --  transitive manner - that is, in case of a subunit, it adds the parent
   --  body, its spec (if any), its parent (if any) etc.
   --  This function supposes that Current Context is correctly set before
   --  the call.

   function In_List
     (U     : Unit_Id;
      L     : Unit_Id_List;
      Up_To : Natural)
      return  Boolean;
   --  Checks if U is a member of the first Up_To components of L. (If
   --  Up_To is 0, False is returned

   procedure CU_To_Unit_Id_List
     (CU_List             :        Compilation_Unit_List;
      Result_Unit_Id_List : in out Unit_Id_List;
      Result_List_Len     : out    Natural);
   --  Converts the ASIS Compilation Unit list into the list of Unit Ids and
   --  places this list into Result_Unit_Id_List. (Probably, we should replace
   --  this routine with a function...)
   --  For each ASIS Compilation Unit from CU_List the Result_Unit_Id_List
   --  contains exactly one Id for the corresponding unit. Result_List_Len is
   --  set to represent the index of the last Unit Id in Result_List_Len (0
   --  in case if Result_List_Len is empty). This routine expects that
   --  Result_Unit_Id_List'Length >= CU_List'Length

   --------------------------------------
   -- Dynamic Unit_Id list abstraction --
   --------------------------------------
   --  All the subprograms implementing Unit_Id list abstraction do not
   --  reset Context

   --  Is this package body the right place for defining this abstraction?
   --  May be, we should move it into A4G.A_Types???

   type Unit_Id_List_Access is access Unit_Id_List;
   Tmp_Unit_Id_List_Access : Unit_Id_List_Access;

   procedure Free is new Ada.Unchecked_Deallocation
     (Unit_Id_List, Unit_Id_List_Access);

   function In_Unit_Id_List
     (U : Unit_Id;
      L : Unit_Id_List_Access)
       return Boolean;
   --  Checks if U is a member of L.

   procedure Append_Unit_To_List
     (U : Unit_Id;
      L : in out Unit_Id_List_Access);
   --  (Unconditionally) appends U to L.

   procedure Add_To_Unit_Id_List
     (U : Unit_Id;
      L : in out Unit_Id_List_Access);
   --  If not In_Unit_Id_List (U, L), U is appended to L (if L is null,
   --  new Unit_Id_List value is created)

   procedure Reorder_Sem_Dependencies (Units : Unit_Id_List_Access);
   --  This procedure takes the unit list with is supposed to be the result of
   --  one of the Set_All_<Relation> functions above (that is, its parameter
   --  is not supposed to be null and it contains only existing units). It
   --  reorders it in the way required by
   --  Asis.Compilation_Units.Relations.Semantic_Dependence_Order - that is,
   --  with no forward semantic dependencies.

   -------------------
   -- Add_To_Parent --
   -------------------

   procedure Add_To_Parent (C : Context_Id; U : Unit_Id) is
      Parent_Id : Unit_Id;
      Unit_Kind : constant Unit_Kinds := Kind (C, U);
   begin

      if U = Standard_Id then
         return;
      end if;

      Reset_Context (C); -- ???

      Get_Name_String (U, Norm_Ada_Name);

      if Not_Root then
         Form_Parent_Name;

         if Unit_Kind in A_Subunit then
            A_Name_Buffer (A_Name_Len) := 'b';
         end if;

         Parent_Id := Name_Find (C);
         --  Parent_Id cannot be Nil_Unit here

            Append_Elmt
              (Unit => U,
               To   => Unit_Table.Table (Parent_Id).Subunits_Or_Childs);
      else
         Append_Elmt
           (Unit => U,
            To   => Unit_Table.Table (Standard_Id).Subunits_Or_Childs);
      end if;

   end Add_To_Parent;

   -------------------------
   -- Add_Unit_Supporters --
   -------------------------

   procedure Add_Unit_Supporters (U : Unit_Id; L : in out Elist_Id) is
      Supporters : Elist_Id        renames Unit_Table.Table (U).Supporters;
      Direct_Supporters : Elist_Id renames
        Unit_Table.Table (U).Direct_Supporters;

      Next_Support_Elmt : Elmt_Id;
      Next_Support_Unit : Unit_Id;

   begin

      if Is_Empty_Elmt_List (Direct_Supporters) then
         --  end of the recursion
         return;

      elsif not Is_Empty_Elmt_List (Supporters) then
         --  no need to traverse indirect dependencies

         Next_Support_Elmt := First_Elmt (Supporters);

         while Present (Next_Support_Elmt) loop
            Next_Support_Unit := Unit (Next_Support_Elmt);

            Add_To_Elmt_List
              (Unit => Next_Support_Unit,
               List => L);

            Next_Support_Elmt := Next_Elmt (Next_Support_Elmt);

         end loop;

      else
         --  And here we have to traverse the recursive dependencies:

         Next_Support_Elmt := First_Elmt (Direct_Supporters);

         while Present (Next_Support_Elmt) loop
            Next_Support_Unit := Unit (Next_Support_Elmt);

            --  The old code currently commented out caused a huge delay
            --  when opening one tree context (8326-002). We will keep it
            --  till the new code is tested for queries from
            --  Asis.Compilation_Units.Relations

            --  ???Old code start

            --  Here we can not be sure, that if Next_Support_Unit already
            --  is in the list, all its supporters also are in the list
            --  Add_To_Elmt_List
            --    (Unit => Next_Support_Unit,
            --     List => L);

            --  Add_Unit_Supporters (Next_Support_Unit, L);

            --  ???Old code end

            --  ???New code start
            if not In_Elmt_List (Next_Support_Unit, L) then
               Append_Elmt
                 (Unit => Next_Support_Unit,
                  To   => L);

               Add_Unit_Supporters (Next_Support_Unit, L);
            end if;

            --  ???New code end

            Next_Support_Elmt := Next_Elmt (Next_Support_Elmt);

         end loop;

      end if;

   end Add_Unit_Supporters;

   -------------------------
   -- Append_Subunit_Name --
   -------------------------

   procedure Append_Subunit_Name (Def_S_Name : Node_Id) is
   begin
      --  Here we need unqualified name, because the name
      --  which comes from the stub is qualified by parent body
      --  name

      Get_Unqualified_Decoded_Name_String (Chars (Def_S_Name));

      A_Name_Buffer (A_Name_Len - 1) := '.';
      A_Name_Buffer (A_Name_Len .. A_Name_Len + Name_Len - 1) :=
         Name_Buffer (1 .. Name_Len);
      A_Name_Len := A_Name_Len + Name_Len + 1;
      A_Name_Buffer (A_Name_Len - 1) := '%';
      A_Name_Buffer (A_Name_Len)     := 'b';
   end Append_Subunit_Name;

   ------------------------
   -- CU_To_Unit_Id_List --
   ------------------------

   procedure CU_To_Unit_Id_List
     (CU_List             :        Compilation_Unit_List;
      Result_Unit_Id_List : in out Unit_Id_List;
      Result_List_Len     : out    Natural)
   is
      Next_Unit       : Unit_Id;
   begin
      Result_List_Len     := 0;

      for I in CU_List'Range loop
         Next_Unit := Get_Unit_Id (CU_List (I));

         if not In_List (Next_Unit, Result_Unit_Id_List, Result_List_Len) then
            Result_List_Len := Result_List_Len + 1;
            Result_Unit_Id_List (Result_List_Len) := Next_Unit;
         end if;

      end loop;

   end CU_To_Unit_Id_List;

   ---------------------------
   -- Fix_Direct_Supporters --
   ---------------------------

   procedure Fix_Direct_Supporters (Unit : Unit_Id) is

      function Next_Supporter (U : Unit_Id) return Unit_Id;
      --  Computes the next supporter to be added (from subunit to the parent
      --  body, from body to the spec, from child to the parent etc). Ends up
      --  with Standard and then with Nil_Unit as its parent

      Next_Supporter_Id : Unit_Id;

      function Next_Supporter (U : Unit_Id) return Unit_Id is
         C             : constant Context_Id := Current_Context;
         Arg_Unit_Kind : constant Unit_Kinds := Kind (C, U);
         Result_Id     : Unit_Id             := Nil_Unit;
      begin

         case Arg_Unit_Kind is

            when A_Procedure                  |
                 A_Function                   |
                 A_Package                    |
                 A_Generic_Procedure          |
                 A_Generic_Function           |
                 A_Generic_Package            |
                 A_Procedure_Instance         |
                 A_Function_Instance          |
                 A_Package_Instance           |
                 A_Procedure_Renaming         |
                 A_Function_Renaming          |
                 A_Package_Renaming           |
                 A_Generic_Procedure_Renaming |
                 A_Generic_Function_Renaming  |
                 A_Generic_Package_Renaming   =>

               Result_Id := Get_Parent_Unit (C, U);

            when  A_Procedure_Body |
                  A_Function_Body  =>

               if Class (C, U) = A_Public_Declaration_And_Body then
                  Result_Id := Get_Parent_Unit (C, U);
               else
                  Result_Id := Get_Declaration (C, U);
               end if;

            when  A_Package_Body =>
               Result_Id := Get_Declaration (C, U);

            when A_Procedure_Body_Subunit |
                 A_Function_Body_Subunit  |
                 A_Package_Body_Subunit   |
                 A_Task_Body_Subunit      |
                 A_Protected_Body_Subunit =>
               Result_Id := Get_Subunit_Parent_Body (C, U);

            when A_Configuration_Compilation =>
               null;
            when others =>
               pragma Assert (False);
               null;
         end case;

         return Result_Id;
      end Next_Supporter;

   begin
      Next_Supporter_Id := Next_Supporter (Unit);

      while Present (Next_Supporter_Id) loop

         Append_Elmt (Unit => Next_Supporter_Id,
                      To   => Unit_Table.Table (Unit).Direct_Supporters);

         Next_Supporter_Id := Next_Supporter (Next_Supporter_Id);
      end loop;

   end Fix_Direct_Supporters;

   --------------------
   -- Get_First_Stub --
   --------------------

   function Get_First_Stub (Body_Node : Node_Id) return Node_Id is
      Decls : List_Id;
      Decl  : Node_Id;
   begin
      Decls := Declarations (Body_Node);

      if No (Decls) then
         return Empty;
      else
         Decl := Nlists.First (Decls);

         while Present (Decl) loop

            if Nkind (Decl) in N_Body_Stub then
               return Decl;
            end if;

            Decl := Next (Decl);
         end loop;
         return Empty;
      end if;

   end Get_First_Stub;

   -------------------
   -- Get_Next_Stub --
   -------------------

   function Get_Next_Stub  (Stub_Node : Node_Id) return Node_Id is
      Next_Decl : Node_Id;
   begin
      Next_Decl := Next (Stub_Node);

      while Present (Next_Decl) loop

         if Nkind (Next_Decl) in N_Body_Stub then
            return Next_Decl;
         end if;

         Next_Decl := Next (Next_Decl);
      end loop;
      return Empty;
   end Get_Next_Stub;

   -------------
   -- In_List --
   -------------

   function In_List
     (U     : Unit_Id;
      L     : Unit_Id_List;
      Up_To : Natural)
      return  Boolean
   is
      Len    : constant Natural := Natural'Min (Up_To, L'Length);
      Result : Boolean          := False;
   begin
      for I in 1 .. Len loop
         if L (I) = U then
            Result := True;
            exit;
         end if;
      end loop;

      return Result;

   end In_List;

   ------------------
   -- Process_Stub --
   ------------------

   procedure Process_Stub (C : Context_Id; U : Unit_Id; Stub : Node_Id) is
      Def_S_Name     : Node_Id;
      Subunit_Id     : Unit_Id;
   begin
      --  We should save (and then restore) the content of A_Name_Buffer in
      --  case when more than one stub is to be processed. (A_Name_Buffer
      --  contains the Ada name of the parent body)

      NB_Save;

      if Nkind (Stub) = N_Subprogram_Body_Stub then
         Def_S_Name := Defining_Unit_Name (Specification (Stub));
      else
         Def_S_Name := Defining_Identifier (Stub);
      end if;

      Append_Subunit_Name (Def_S_Name);

      Subunit_Id := Name_Find (C);

      if No (Subunit_Id) then
         Subunit_Id := Allocate_Nonexistent_Unit_Entry (C);
         Append_Elmt (Unit => Subunit_Id,
                      To   => Unit_Table.Table (U).Subunits_Or_Childs);
      end if;

      NB_Restore;

   end Process_Stub;

   ------------------------------
   -- Reorder_Sem_Dependencies --
   ------------------------------

   procedure Reorder_Sem_Dependencies (Units : Unit_Id_List_Access) is
      More_Inversion : Boolean := True;
      Tmp_Unit       : Unit_Id;
   begin

      if Units'Length = 0 then
         return;
      end if;

      --  The idea is simple: for all the units in Units list we have the
      --  lists of all the unit's supporters already computed. If we order
      --  units so that the lengths of supporter lists will increase we will
      --  get the order in which there will be no forward semantic
      --  dependencies: if unit A depends on unit B, then A also depends on
      --  all the supporters of B, so it has the list of supporters longer
      --  then B has

      while More_Inversion loop

         More_Inversion := False;

         for J in Units'First .. Units'Last - 1 loop

            if List_Length (Unit_Table.Table (Units (J)).Supporters) >
               List_Length (Unit_Table.Table (Units (J + 1)).Supporters)
            then
               Tmp_Unit       := Units (J + 1);
               Units (J + 1)  := Units (J);
               Units (J)      := Tmp_Unit;
               More_Inversion := True;
            end if;

         end loop;

      end loop;

   end Reorder_Sem_Dependencies;

   --------------------------
   -- Set_All_Dependencies --
   --------------------------

   procedure Set_All_Dependencies (Use_First_New_Unit : Boolean := False) is
      Starting_Unit : Unit_Id;
   begin

      if Use_First_New_Unit then
         Starting_Unit := First_New_Unit;

         if No (Starting_Unit) then
            --  This may happen, when, for the incremental Context, we
            --  process the tree which is the main tree for some body unit,
            --  and this body unit has been already included in the Context
            --  (See Lib (spec, (h))
            return;
         end if;

      else
         Starting_Unit := Standard_Id + 1;
         --  Standard_Id corresponds to last predefined unit set in the
         --  unit table  ???
      end if;

      for U in Starting_Unit .. Last_Unit loop
         Set_All_Unit_Dependencies (U);
      end loop;
   end Set_All_Dependencies;

   -------------------------------
   -- Set_All_Unit_Dependencies --
   -------------------------------

   procedure Set_All_Unit_Dependencies (U : Unit_Id) is
      Supporters        : Elist_Id renames Unit_Table.Table (U).Supporters;
      Direct_Supporters : Elist_Id renames
        Unit_Table.Table (U).Direct_Supporters;

      Next_Support_Elmt : Elmt_Id;
      Next_Support_Unit : Unit_Id;

   begin

      Fix_Direct_Supporters (U);

      --  Setting all the unit supporters
      Next_Support_Elmt := First_Elmt (Direct_Supporters);

      while Present (Next_Support_Elmt) loop
         Next_Support_Unit := Unit (Next_Support_Elmt);

         --  If Next_Support_Unit already is in Supporters list,
         --  all its supporters also are already included in Supporters.

         if not In_Elmt_List (Next_Support_Unit, Supporters) then
            Append_Elmt
              (Unit => Next_Support_Unit,
               To   => Supporters);

            Add_Unit_Supporters (Next_Support_Unit, Supporters);
         end if;

         Next_Support_Elmt := Next_Elmt (Next_Support_Elmt);

      end loop;

      --  And now - adding U as depended unit to the list of Dependents for
      --  all its supporters

      Next_Support_Elmt := First_Elmt (Supporters);

      while Present (Next_Support_Elmt) loop
         Next_Support_Unit := Unit (Next_Support_Elmt);

         Append_Elmt
           (Unit => U,
            To   => Unit_Table.Table (Next_Support_Unit).Dependents);

         Next_Support_Elmt := Next_Elmt (Next_Support_Elmt);
      end loop;

   end Set_All_Unit_Dependencies;

   ---------------------------
   -- Set_Direct_Dependents --
   ---------------------------

   procedure Set_Direct_Dependents (U : Unit_Id) is
      Next_Support_Elmt : Elmt_Id;
      Next_Support_Unit : Unit_Id;
   begin
      Next_Support_Elmt := First_Elmt (Unit_Table.Table (U).Direct_Supporters);

      while Present (Next_Support_Elmt) loop
         Next_Support_Unit := Unit (Next_Support_Elmt);

         Append_Elmt
           (Unit => U,
            To   => Unit_Table.Table (Next_Support_Unit).Direct_Dependents);

         Next_Support_Elmt := Next_Elmt (Next_Support_Elmt);
      end loop;

   end Set_Direct_Dependents;

   -----------------------
   -- Set_All_Ancestors --
   -----------------------

   procedure Set_All_Ancestors
     (Compilation_Units :        Asis.Compilation_Unit_List;
      Result            : in out Compilation_Unit_List_Access)
   is
      Cont     : constant Context_Id := Current_Context;

      Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) :=
        (others => Nil_Unit);

      Arg_List_Len       : Natural             := 0;
      Result_List        : Unit_Id_List_Access := null;
      Next_Ancestor_Unit : Unit_Id;

   begin
      --  For the current version, we are supposing, that we have only one
      --  Context opened at a time

      CU_To_Unit_Id_List (Compilation_Units, Arg_List, Arg_List_Len);

      --  Standard is an ancestor of any unit, and if we are here,
      --  Compilation_Units can not be Nil_Compilation_Unit_List. So we set
      --  it as the first element of the result list:

      Append_Unit_To_List (Standard_Id, Result_List);

      for I in 1 .. Arg_List_Len loop

         Next_Ancestor_Unit := Arg_List (I);

         if Next_Ancestor_Unit /= Standard_Id then

            while Kind (Cont, Next_Ancestor_Unit) in A_Subunit loop
               Next_Ancestor_Unit :=
                  Get_Subunit_Parent_Body (Cont, Next_Ancestor_Unit);
            end loop;

            if Class (Cont, Next_Ancestor_Unit) = A_Public_Body or else
               Class (Cont, Next_Ancestor_Unit) = A_Private_Body
            then
               Next_Ancestor_Unit :=
                  Get_Declaration (Cont, Next_Ancestor_Unit);
            end if;

            while Next_Ancestor_Unit /= Standard_Id loop

               if not In_Unit_Id_List (Next_Ancestor_Unit, Result_List) then

                  Append_Unit_To_List (Next_Ancestor_Unit, Result_List);
                  Next_Ancestor_Unit :=
                     Get_Parent_Unit (Cont, Next_Ancestor_Unit);
               else
                  exit;
               end if;

            end loop;

         end if;

      end loop;

      --  And here we have to order Result_List to eliminate forward
      --  semantic dependencies

      --  Result_List can not be null - it contains at least Standard_Id

      Reorder_Sem_Dependencies (Result_List);

      Result := new Compilation_Unit_List'
                     (Get_Comp_Unit_List (Result_List.all, Cont));
      Free (Result_List);

   end Set_All_Ancestors;

   ------------------------
   -- Set_All_Dependents --
   ------------------------

   procedure Set_All_Dependents
     (Compilation_Units :        Asis.Compilation_Unit_List;
      Dependent_Units   :        Asis.Compilation_Unit_List;
      Result            : in out Compilation_Unit_List_Access)
   is
      Cont            : constant Context_Id := Current_Context;

      Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) :=
        (others => Nil_Unit);

      Arg_List_Len : Natural := 0;

      Dep_List : Unit_Id_List (1 .. Dependent_Units'Length) :=
        (others => Nil_Unit);

      Dep_List_Len        : Natural := 0;
      Result_List         : Unit_Id_List_Access := null;
      Next_Dependent_Elmt : Elmt_Id;
      Next_Dependent_Unit : Unit_Id;

   begin
      --  For the current version, we are supposing, that we have only one
      --  Context opened at a time

      CU_To_Unit_Id_List (Compilation_Units, Arg_List, Arg_List_Len);
      CU_To_Unit_Id_List (Dependent_Units,   Dep_List, Dep_List_Len);

      --  Now, collecting all the dependents for Compilation_Units

      for I in 1 .. Arg_List_Len loop

         Next_Dependent_Elmt :=
            First_Elmt (Unit_Table.Table (Arg_List (I)).Dependents);

         while Present (Next_Dependent_Elmt) loop
            Next_Dependent_Unit := Unit (Next_Dependent_Elmt);

            if Dep_List_Len = 0 or else
               In_List (Next_Dependent_Unit, Dep_List, Dep_List_Len)
            then
               Add_To_Unit_Id_List (Next_Dependent_Unit, Result_List);
            end if;

            Next_Dependent_Elmt := Next_Elmt (Next_Dependent_Elmt);

         end loop;

      end loop;

      --  And here we have to order Result_List to eliminate forward
      --  semantic dependencies

      if Result_List /= null then
         Reorder_Sem_Dependencies (Result_List);

         Result := new Compilation_Unit_List'
                        (Get_Comp_Unit_List (Result_List.all, Cont));
         Free (Result_List);
      else
         Result := new Compilation_Unit_List (1 .. 0);
      end if;

   end Set_All_Dependents;

   -------------------------
   -- Set_All_Descendants --
   -------------------------

   procedure Set_All_Descendants
     (Compilation_Units :        Asis.Compilation_Unit_List;
      Result            : in out Compilation_Unit_List_Access)
   is
      Cont : constant Context_Id := Current_Context;

      Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) :=
        (others => Nil_Unit);

      Arg_List_Len         : Natural             := 0;
      Result_List          : Unit_Id_List_Access := null;
      Next_Descendant_Elmt : Elmt_Id;
      Next_Unit            : Unit_Id;

      procedure Add_All_Descendants
        (Desc_Unit   : Unit_Id;
         Result_List : in out Unit_Id_List_Access);
      --  If Desc_Unit is not in Result_List, this procedure adds it and
      --  (recursively) all its descendants which are not in Result_List to
      --  the list.

      procedure Add_All_Descendants
        (Desc_Unit   : Unit_Id;
         Result_List : in out Unit_Id_List_Access)
      is
         Child_Elmt : Elmt_Id;
         Child_Unit : Unit_Id;
      begin

         if not In_Unit_Id_List (Desc_Unit, Result_List) then
            Append_Unit_To_List (Desc_Unit, Result_List);

            if Kind (Cont, Desc_Unit) = A_Package          or else
               Kind (Cont, Desc_Unit) = A_Generic_Package  or else
               Kind (Cont, Desc_Unit) = A_Package_Renaming or else
               Kind (Cont, Desc_Unit) = A_Generic_Package_Renaming
            then
               Child_Elmt :=
                  First_Elmt (Unit_Table.Table (Desc_Unit).Subunits_Or_Childs);

               while Present (Child_Elmt) loop
                  Child_Unit := Unit (Child_Elmt);

                  Add_All_Descendants (Child_Unit, Result_List);

                  Child_Elmt := Next_Elmt (Child_Elmt);
               end loop;

            end if;

         end if;

      end Add_All_Descendants;

   begin

      --  We can not use CU_To_Unit_Id_List routine, because we have to
      --  filter out subunits, nonexistent units (?) and bodies for which the
      --  Context does not contain a spec - such units can not have
      --  descendants. For bodies, only the corresponding specs contain the
      --  lists of descendants.

      for I in Compilation_Units'Range loop
         Next_Unit := Get_Unit_Id (Compilation_Units (I));

         if Kind (Cont, Next_Unit) not in A_Procedure_Body_Subunit ..
                                    A_Nonexistent_Body
         then

            if Kind (Cont, Next_Unit) in A_Library_Unit_Body then
               Next_Unit := Get_Declaration (Cont, Next_Unit);
            end if;

            if Present (Next_Unit) and then
               (not In_List (Next_Unit, Arg_List, Arg_List_Len))
            then
               Arg_List_Len := Arg_List_Len + 1;
               Arg_List (Arg_List_Len) := Next_Unit;
            end if;

         end if;

      end loop;

      for J in 1 .. Arg_List_Len loop
         Next_Descendant_Elmt :=
            First_Elmt (Unit_Table.Table (Arg_List (J)).Subunits_Or_Childs);

         while Present (Next_Descendant_Elmt) loop
            Next_Unit := Unit (Next_Descendant_Elmt);
            Add_All_Descendants (Next_Unit, Result_List);
            Next_Descendant_Elmt := Next_Elmt (Next_Descendant_Elmt);
         end loop;

      end loop;

      if Result_List /= null then
         Reorder_Sem_Dependencies (Result_List);

         Result := new Compilation_Unit_List'
                        (Get_Comp_Unit_List (Result_List.all, Cont));
         Free (Result_List);
      else
         Result := new Compilation_Unit_List (1 .. 0);
      end if;

   end Set_All_Descendants;

   ----------------------
   -- Set_All_Families --
   ----------------------

   procedure Set_All_Families
     (Compilation_Units :        Asis.Compilation_Unit_List;
      Result            : in out Compilation_Unit_List_Access)
   is
      Cont : constant Context_Id := Current_Context;

      Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) :=
        (others => Nil_Unit);

      Arg_List_Len : Natural := 0;
      Result_List  : Unit_Id_List_Access := null;

      procedure Collect_Spec_Family
        (Spec_Unit   : Unit_Id;
         Result_List : in out Unit_Id_List_Access);
      --  If Spec_Unit is not in Result_List, this procedure adds it and
      --  (recursively) all members of its family which are not in Result_List
      --  to the list. In case of a spec, the corresponding body's family is
      --  also added

      procedure Collect_Body_Family
        (Body_Unit   : Unit_Id;
         Result_List : in out Unit_Id_List_Access);
      --  If Body_Unit is not in Result_List, this procedure adds it and
      --  (recursively) all members of its family which are not in Result_List
      --  to the list. In case of a body, only the subunit tree rooted by this
      --  body may be added

      procedure Collect_Spec_Family
        (Spec_Unit   : Unit_Id;
         Result_List : in out Unit_Id_List_Access)
      is
         Child_Elmt : Elmt_Id;
         Child_Unit : Unit_Id;
      begin

         if not In_Unit_Id_List (Spec_Unit, Result_List) then
            Append_Unit_To_List (Spec_Unit, Result_List);

            --  We have to add all descendants (if any) and their families

            if Kind (Cont, Spec_Unit) = A_Package          or else
               Kind (Cont, Spec_Unit) = A_Generic_Package  or else
               Kind (Cont, Spec_Unit) = A_Package_Renaming or else
               Kind (Cont, Spec_Unit) = A_Generic_Package_Renaming
            then
               Child_Elmt :=
                  First_Elmt (Unit_Table.Table (Spec_Unit).Subunits_Or_Childs);

               while Present (Child_Elmt) loop
                  Child_Unit := Unit (Child_Elmt);

                  if Kind (Cont, Child_Unit) in
                     A_Procedure .. A_Generic_Package_Renaming
                  then

                     Collect_Spec_Family (Child_Unit, Result_List);

                  elsif Kind (Cont, Child_Unit) in
                     A_Procedure_Body .. A_Protected_Body_Subunit
                  then

                     Collect_Body_Family (Child_Unit, Result_List);

                  end if;

                  Child_Elmt := Next_Elmt (Child_Elmt);
               end loop;

            end if;

         end if;

      end Collect_Spec_Family;

      procedure Collect_Body_Family
        (Body_Unit   : Unit_Id;
         Result_List : in out Unit_Id_List_Access)
      is
         Child_Elmt : Elmt_Id;
         Child_Unit : Unit_Id;
      begin

         if not In_Unit_Id_List (Body_Unit, Result_List) then
            Append_Unit_To_List (Body_Unit, Result_List);

            --  We have to add all descendants (if any) and their families

            if Kind (Cont, Body_Unit) in
               A_Procedure_Body .. A_Protected_Body_Subunit
            then
               Child_Elmt :=
                  First_Elmt (Unit_Table.Table (Body_Unit).Subunits_Or_Childs);

               while Present (Child_Elmt) loop
                  Child_Unit := Unit (Child_Elmt);
                  Collect_Body_Family (Child_Unit, Result_List);
                  Child_Elmt := Next_Elmt (Child_Elmt);
               end loop;

            end if;

         end if;

      end Collect_Body_Family;

   begin
      CU_To_Unit_Id_List (Compilation_Units, Arg_List, Arg_List_Len);

      for J in 1 .. Arg_List_Len loop

         case Class (Cont, Arg_List (J)) is

            when A_Public_Declaration |
                 A_Private_Declaration =>

               Collect_Spec_Family (Arg_List (J), Result_List);

            when Not_A_Class =>
               --  This should never happen, so just in case we
               --  raise an exception
               null;
               pragma Assert (False);

            when others =>
               --  Here we can have only a body or a separate body
               Collect_Body_Family (Arg_List (J), Result_List);
         end case;

      end loop;

      --  And here we have to order Result_List to eliminate forward
      --  semantic dependencies

      if Result_List /= null then
         Reorder_Sem_Dependencies (Result_List);

         Result := new Compilation_Unit_List'
                        (Get_Comp_Unit_List (Result_List.all, Cont));
         Free (Result_List);
      else
         Result := new Compilation_Unit_List (1 .. 0);
      end if;

   end Set_All_Families;

   ------------------------
   -- Set_All_Supporters --
   ------------------------

   package Unit_Container is new Ada.Containers.Ordered_Sets
     (Element_Type => Unit_Id);

   procedure Unit_List_To_Set
     (Unit_List :        Elist_Id;
      Unit_Set  : in out Unit_Container.Set);
   --  Assuming that Unit_List does not contain repeating elements, creates
   --  Unit_Set as the set containing Unit IDs from Unit_List. If Unit_Set is
   --  non-empty before the call, the old content of the set is lost.

   function Unit_Set_To_List
     (Unit_Set : Unit_Container.Set)
      return    Unit_Id_List;
   --  Converts the unit id set into array

   Result_Set            : Unit_Container.Set;
   New_Set               : Unit_Container.Set;
   Newer_Set             : Unit_Container.Set;
   Next_Direct_Supporter : Unit_Container.Cursor;

   procedure Unit_List_To_Set
     (Unit_List :        Elist_Id;
      Unit_Set  : in out Unit_Container.Set)
   is
      Next_El   : Elmt_Id;
   begin
      Unit_Container.Clear (Unit_Set);

      Next_El := First_Elmt (Unit_List);

      while Present (Next_El) loop
         Unit_Container.Insert (Unit_Set, Unit (Next_El));
         Next_El := Next_Elmt (Next_El);
      end loop;
   end Unit_List_To_Set;

   function Unit_Set_To_List
     (Unit_Set : Unit_Container.Set)
      return    Unit_Id_List
   is
      Next_Unit : Unit_Container.Cursor;
      Result : Unit_Id_List (1 .. Natural (Unit_Container.Length (Unit_Set)));
      Next_Idx : Natural := Result'First;
   begin
      Next_Unit := Unit_Container.First (Unit_Set);

      while Unit_Container.Has_Element (Next_Unit) loop
         Result (Next_Idx) := Unit_Container.Element (Next_Unit);
         Next_Idx          := Next_Idx + 1;
         Next_Unit         := Unit_Container.Next (Next_Unit);
      end loop;

      return Result;
   end Unit_Set_To_List;

   procedure Set_All_Supporters
     (Compilation_Units :        Asis.Compilation_Unit_List;
      Result            : in out Compilation_Unit_List_Access)

   is
      Cont            : constant Context_Id := Current_Context;

      Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) :=
        (others => Nil_Unit);

      Result_List  : Unit_Id_List_Access := null;
      Arg_List_Len : Natural := 0;
      pragma Unreferenced (Arg_List_Len);

      procedure Collect_Supporters (U : Unit_Id);
      --  If U is not presented in Result, adds (recursively) all its
      --  supporters to Result_List
      --  Uses workpile algorithm to avoid cycling (cycling is possible because
      --  of limited with)

      procedure Collect_Supporters (U : Unit_Id) is
         Next_Supporter : Elmt_Id;
      begin

         Unit_Container.Clear (New_Set);
         Unit_Container.Clear (Newer_Set);

         Unit_List_To_Set
           (Unit_List => Unit_Table.Table (U).Supporters,
            Unit_Set  => New_Set);

         Unit_Container.Union
           (Target => Result_Set,
            Source => New_Set);

         while not Unit_Container.Is_Empty (New_Set) loop
            Next_Direct_Supporter := Unit_Container.First (New_Set);

            Next_Supporter :=
              First_Elmt (Unit_Table.Table
                (Unit_Container.Element (Next_Direct_Supporter)).Supporters);

            while Present (Next_Supporter) loop
               if not Unit_Container.Contains
                        (Result_Set, Unit (Next_Supporter))
               then
                  Unit_Container.Insert (Newer_Set, Unit (Next_Supporter));
               end if;

               Next_Supporter := Next_Elmt (Next_Supporter);
            end loop;

            Unit_Container.Delete_First (New_Set);

            if not Unit_Container.Is_Empty (Newer_Set) then
               Unit_Container.Union (Result_Set, Newer_Set);
               Unit_Container.Union (New_Set, Newer_Set);
               Unit_Container.Clear (Newer_Set);
            end if;
         end loop;

      end Collect_Supporters;

   begin
      Unit_Container.Clear (Result_Set);
      Unit_Container.Insert (Result_Set, Standard_Id);

      --  For the current version, we are supposing, that we have only one
      --  Context opened at a time

      CU_To_Unit_Id_List (Compilation_Units, Arg_List, Arg_List_Len);

      --  Now, collecting all the supporters for Compilation_Units

      --  Standard is a supporter of any unit, and if we are here,
      --  Compilation_Units can not be Nil_Compilation_Unit_List. So we set
      --  it as the first element of the result list:

      for J in Compilation_Units'Range loop
         Collect_Supporters (Get_Unit_Id (Compilation_Units (J)));
      end loop;

      Result_List := new Unit_Id_List'(Unit_Set_To_List (Result_Set));

      --  And here we have to order Result_List to eliminate forward
      --  semantic dependencies

      --  Result_List can not be null - it contains at least Standard_Id

      Reorder_Sem_Dependencies (Result_List);

      Result := new Compilation_Unit_List'
                     (Get_Comp_Unit_List (Result_List.all, Cont));
      Free (Result_List);

   end Set_All_Supporters;

   --------------------------
   -- Set_All_Needed_Units --
   --------------------------

   procedure Set_All_Needed_Units
     (Compilation_Units :        Asis.Compilation_Unit_List;
      Result            : in out Compilation_Unit_List_Access;
      Missed            : in out Compilation_Unit_List_Access)
   is
      Cont            : constant Context_Id := Current_Context;
      Cont_Tree_Mode  : constant Tree_Mode  := Tree_Processing_Mode (Cont);

      Arg_List        : Unit_Id_List (1 .. Compilation_Units'Length) :=
                        (others => Nil_Unit);
      Arg_List_Len    : Natural := 0;

      Result_List     : Unit_Id_List_Access := null;
      Missed_List     : Unit_Id_List_Access := null;

      procedure Set_One_Unit (U : Unit_Id);
      --  Provided that U is an (existing) unit which is not in the
      --  Result_List, this procedure adds this unit and all the units
      --  needed by it to result lists.

      procedure Add_Needed_By_Spec (Spec_Unit : Unit_Id);
      --  Provided that Spec_Unit denotes an (existing) spec, this procedure
      --  adds to the result lists units which are needed by this unit only,
      --  that is, excluding this unit (it is supposed to be already added at
      --  the moment of the call), its body and units needed by the body (if
      --  any, they are processed separately)

      procedure Add_Needed_By_Body (Body_Unit : Unit_Id);
      --  Provided that Body_Unit denotes an (existing) body, this procedure
      --  adds to the result lists units which are needed by this unit,
      --  excluding the unit itself (it is supposed to be already added at
      --  the moment of the call). That is, the spec of this unit and units
      --  which are needed by the spec (if any) are also needed, if they have
      --  not been added before

      ------------------------
      -- Add_Needed_By_Body --
      ------------------------

      procedure Add_Needed_By_Body (Body_Unit : Unit_Id) is
         Spec_Unit : Unit_Id;

         Subunit_List : constant Unit_Id_List := Subunits (Cont, Body_Unit);

         Next_Support_Elmt : Elmt_Id;
         Next_Support_Unit : Unit_Id;

      begin

         --  First, check if there is a separate spec then it has to be
         --  processed

         if Class (Cont, Body_Unit) /= A_Public_Declaration_And_Body then

            Spec_Unit := Body_Unit;

            while Class (Cont, Spec_Unit) = A_Separate_Body loop
               Spec_Unit := Get_Subunit_Parent_Body (Cont, Spec_Unit);
            end loop;

            Spec_Unit := Get_Declaration (Cont, Spec_Unit);
            --  We can not get Nil or nonexistent unit here

            if not In_Unit_Id_List (Spec_Unit, Result_List) then
               Add_Needed_By_Spec (Spec_Unit);
            end if;

         end if;

         --  Now process body's supporters:

         Next_Support_Elmt :=
            First_Elmt (Unit_Table.Table (Body_Unit).Supporters);

         while Present (Next_Support_Elmt) loop

            Next_Support_Unit := Unit (Next_Support_Elmt);

            if not In_Unit_Id_List (Next_Support_Unit, Result_List) then
               Set_One_Unit (Next_Support_Unit);
            end if;

            Next_Support_Elmt := Next_Elmt (Next_Support_Elmt);

         end loop;

         --  And, finally, subunits:

         for J in Subunit_List'Range loop

            if Kind (Cont, Subunit_List (J)) = A_Nonexistent_Body then
               Append_Unit_To_List (Subunit_List (J), Missed_List);

            elsif not In_Unit_Id_List (Subunit_List (J), Result_List) then
               Append_Unit_To_List (Subunit_List (J), Result_List);
               Add_Needed_By_Body  (Subunit_List (J));
            end if;

         end loop;

      end Add_Needed_By_Body;

      ------------------------
      -- Add_Needed_By_Spec --
      ------------------------

      procedure Add_Needed_By_Spec (Spec_Unit : Unit_Id) is
         Next_Support_Elmt : Elmt_Id;
         Next_Support_Unit : Unit_Id;
      begin

         Next_Support_Elmt :=
            First_Elmt (Unit_Table.Table (Spec_Unit).Supporters);

         while Present (Next_Support_Elmt) loop

            Next_Support_Unit := Unit (Next_Support_Elmt);

            if not In_Unit_Id_List (Next_Support_Unit, Result_List) then
               Set_One_Unit (Next_Support_Unit);
            end if;

            Next_Support_Elmt := Next_Elmt (Next_Support_Elmt);

         end loop;

      end Add_Needed_By_Spec;

      ------------------
      -- Set_One_Unit --
      ------------------

      procedure Set_One_Unit (U : Unit_Id) is
         U_Body : Unit_Id;
      begin
         Append_Unit_To_List (U, Result_List);

         case Class (Cont, U) is

            when A_Public_Declaration |
                 A_Private_Declaration =>

               Add_Needed_By_Spec (U);

               if Is_Body_Required (Cont, U) then
                  U_Body := Get_Body (Cont, U);

                  if No (U_Body) and then
                     (Cont_Tree_Mode = On_The_Fly
                    or else
                      Cont_Tree_Mode = Mixed)
                  then
                     --  Is it a correct thing to compile something on the fly
                     --  Inside the query from Relations???
                     U_Body := Get_One_Unit
                       (Name    => To_Program_Text
                                     (Unit_Name (Get_Comp_Unit (U, Cont))),
                        Context => Cont,
                        Spec    => False);
                  end if;

                  if Present (U_Body) then

                     if Kind (Cont, U_Body) in A_Nonexistent_Declaration ..
                                               A_Nonexistent_Body
                     then
                        Add_To_Unit_Id_List (U_Body, Missed_List);

                     elsif not In_Unit_Id_List (U_Body, Result_List) then
                        Append_Unit_To_List (U_Body, Result_List);
                        Add_Needed_By_Body  (U_Body);
                     end if;

                  else
                     U_Body := Get_Nonexistent_Unit (Cont);
                     Append_Unit_To_List (U_Body, Missed_List);
                  end if;

               end if;

            when Not_A_Class =>
               --  This should never happen, so just in case we
               --  raise an exception
               null;
               pragma Assert (False);

            when others =>
               Add_Needed_By_Body (U);
         end case;

      end Set_One_Unit;

   begin --  Set_All_Needed_Units

      CU_To_Unit_Id_List (Compilation_Units, Arg_List, Arg_List_Len);

      --  Standard is a supporter of any unit, and if we are here,
      --  Compilation_Units can not be Nil_Compilation_Unit_List. So we set
      --  it as the first element of the result list:

      Append_Unit_To_List (Standard_Id, Result_List);

      for J in 1 .. Arg_List_Len loop

         if not In_Unit_Id_List (Arg_List (J), Result_List) then
            Set_One_Unit (Arg_List (J));
         end if;

      end loop;

      --  Result_List can not be null - it contains at least Standard_Id

      Reorder_Sem_Dependencies (Result_List);

      Result := new Compilation_Unit_List'
                     (Get_Comp_Unit_List (Result_List.all, Cont));
      Free (Result_List);

      if Missed_List /= null then
         Missed := new Compilation_Unit_List'
                        (Get_Comp_Unit_List (Missed_List.all, Cont));
         Free (Missed_List);
      else
         Missed := new Compilation_Unit_List (1 .. 0);
      end if;

   end Set_All_Needed_Units;

   ------------------
   -- Set_Subunits --
   ------------------

   procedure Set_Subunits (C : Context_Id; U : Unit_Id; Top : Node_Id) is
      Body_Node : Node_Id;
      Stub_Node : Node_Id;
   begin
      Get_Name_String (U, Norm_Ada_Name);
      Body_Node := Unit (Top);

      if Nkind (Body_Node) = N_Subunit then
         Body_Node := Proper_Body (Body_Node);
      end if;

      Stub_Node := Get_First_Stub (Body_Node);

      if No (Stub_Node) then
         return;
      end if;

      while Present (Stub_Node) loop
         Process_Stub (C, U, Stub_Node);
         Stub_Node := Get_Next_Stub (Stub_Node);
      end loop;

      Unit_Table.Table (U).Subunits_Computed := True;

   end Set_Subunits;

   --------------------
   -- Set_Supporters --
   --------------------

   procedure Set_Supporters (C : Context_Id; U : Unit_Id; Top : Node_Id) is
   begin
      Set_Withed_Units      (C, U, Top);
      Set_Direct_Dependents (U);
   end Set_Supporters;

   ----------------------
   -- Set_Withed_Units --
   ----------------------

   procedure Set_Withed_Units (C : Context_Id; U : Unit_Id; Top : Node_Id)
   is
      With_Clause_Node  : Node_Id;
      Cunit_Node        : Node_Id;
      Cunit_Number      : Unit_Number_Type;
      Current_Supporter : Unit_Id;
      Tmp               : Unit_Id;
      Include_Unit      : Boolean := False;
   begin
      --  the maim control structure - cycle through the with clauses
      --  in the tree
      if No (Context_Items (Top)) then
         return;
      end if;

      With_Clause_Node := First_Non_Pragma (Context_Items (Top));

      while Present (With_Clause_Node) loop
         --  here we simply get the name of the next supporting unit from
         --  the GNAT Units Table (defined in Lib)
         Cunit_Node    := Library_Unit (With_Clause_Node);
         Cunit_Number  := Get_Cunit_Unit_Number (Cunit_Node);
         Get_Decoded_Name_String (Unit_Name (Cunit_Number));

         Set_Norm_Ada_Name_String_With_Check (Cunit_Number, Include_Unit);

         if Include_Unit then

            Current_Supporter := Name_Find (C);

            if A_Name_Buffer (A_Name_Len) = 'b' then
               A_Name_Buffer (A_Name_Len) := 's';
               Tmp := Name_Find (C);

               if Present (Tmp) then
                  --  OPEN PROBLEM: is this the best solution for this problem?
                  --
                  --  Here we are in the potentially hard-to-report-about and
                  --  definitely involving inconsistent unit set situation.
                  --  The last version of U depends on subprogram body at least
                  --  in one of the consistent trees, but the Context contains
                  --  a spec (that is, a library_unit_declaration or a
                  --  library_unit_renaming_declaration) for the same full
                  --  expanded Ada name. The current working decision is
                  --  to set this dependency as if U depends on the spec.
                  --
                  --  Another (crazy!) problem: in one consistent tree
                  --  U depends on the package P (and P does not require a
                  --  body), and in another consistent tree U depends on
                  --  the procedure P which is presented by its body only.
                  --  It may be quite possible, if these trees were created
                  --  with different search paths. Is our decision reasonable
                  --  for this crazy situation :-[ ??!!??

                  Current_Supporter := Tmp;
               end if;

            end if;

            --  and now we store this dependency - we have to use
            --  Add_To_Elmt_List instead of Append_Elmt - some units
            --  may be mentioned several times in the context clause:
            if Implicit_With (With_Clause_Node) then
               Add_To_Elmt_List
                 (Unit => Current_Supporter,
                  List => Unit_Table.Table (U).Implicit_Supporters);
            else
               Add_To_Elmt_List
                 (Unit => Current_Supporter,
                  List => Unit_Table.Table (U).Direct_Supporters);
            end if;
         end if;

         With_Clause_Node := Next_Non_Pragma (With_Clause_Node);

         while Present (With_Clause_Node) and then
               Nkind (With_Clause_Node) /= N_With_Clause
         loop
            With_Clause_Node := Next_Non_Pragma (With_Clause_Node);
         end loop;

      end loop;
   end Set_Withed_Units;

   -------------------------------------------------------
   -- Dynamic Unit_Id list abstraction (implementation) --
   -------------------------------------------------------

   ----------------------
   --  In_Unit_Id_List --
   ----------------------

   function In_Unit_Id_List
     (U    : Unit_Id;
      L    : Unit_Id_List_Access)
      return Boolean
   is
   begin

      if L /= null then

         for I in L'Range loop

            if U = L (I) then
               return True;
            end if;

         end loop;

      end if;

      return False;
   end In_Unit_Id_List;

   --------------------------
   --  Add_To_Unit_Id_List --
   --------------------------

   procedure Add_To_Unit_Id_List
     (U : Unit_Id;
      L : in out Unit_Id_List_Access)
   is
   begin

      if not In_Unit_Id_List (U, L) then
         Append_Unit_To_List (U, L);
      end if;

   end Add_To_Unit_Id_List;

   -------------------------
   -- Append_Unit_To_List --
   -------------------------

   procedure Append_Unit_To_List
     (U : Unit_Id;
      L : in out Unit_Id_List_Access)
   is
   begin

      if L = null then
         L := new Unit_Id_List'(1 => U);
      else
         Free (Tmp_Unit_Id_List_Access);
         Tmp_Unit_Id_List_Access := new Unit_Id_List'(L.all & U);
         Free (L);
         L := new Unit_Id_List'(Tmp_Unit_Id_List_Access.all);
      end if;

   end Append_Unit_To_List;

end A4G.Contt.Dp;