------------------------------------------------------------------------------
-- --
-- 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 --
-- . --
-- --
-- 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_ 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;