|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: B T
Length: 42997 (0xa7f5)
Types: TextFile
Names: »B«
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
└─⟦129cab021⟧ »DATA«
└─⟦this⟧
└─⟦2f6cfab89⟧ Bits:30000547 8mm tape, Rational 1000, !projects 94-01-04
└─⟦d65440be7⟧ »DATA«
└─⟦this⟧
with Diana;
with Directory;
with Object_Subclass;
with String_Utilities;
with Semantic_Attributes;
with Activity_Implementation;
package body Object_Sets is
--
function "=" (This_Class : in Directory_Tools.Object.Class_Enumeration;
That_Class : in Directory_Tools.Object.Class_Enumeration)
return Boolean renames Directory_Tools.Object."=";
--
function "=" (This_Kind : in Directory_Tools.Ada_Object.Compilation_Kind;
That_Kind : in Directory_Tools.Ada_Object.Compilation_Kind)
return Boolean renames Directory_Tools.Ada_Object."=";
--
function "=" (This_Kind : in Directory_Tools.Ada_Object.Unit_Kind;
That_Kind : in Directory_Tools.Ada_Object.Unit_Kind)
return Boolean renames Directory_Tools.Ada_Object."=";
--
function "+" (This_Set : in Object_Set; That_Set : in Object_Set)
return Object_Set renames Union;
--
function Empty_Set return Object_Set is
begin
return (Directory_Tools.Object.Create);
end Empty_Set;
--
function Is_Empty (This_Set : in Object_Set) return Boolean is
begin
return (Number_In (This_Set) = 0);
end Is_Empty;
--
function Number_In (This_Set : in Object_Set) return Natural is
--
Working_Set : Object_Set := This_Set;
Count : Natural := 0;
--
begin
Directory_Tools.Object.Reset (Working_Set);
while (not Directory_Tools.Object.Done (Working_Set)) loop
Count := Count + 1;
Directory_Tools.Object.Next (Working_Set);
end loop;
return (Count);
end Number_In;
--
function Are_Equal (This_Set : in Object_Set; That_Set : in Object_Set)
return Boolean is
--
Working_Set : Object_Set := This_Set;
Result : Boolean := True;
--
begin
if (Number_In (This_Set) /= Number_In (That_Set)) then
Result := False;
else
Directory_Tools.Object.Reset (Working_Set);
while (not Directory_Tools.Object.Done (Working_Set)) loop
if (not Is_Member (That_Set, Directory_Tools.Object.Value
(Working_Set))) then
-- Found object in one set which isn't in other set.
Result := False;
exit;
end if;
Directory_Tools.Object.Next (Working_Set);
end loop;
end if;
return (Result);
end Are_Equal;
--
function Copy_Of (This_Set : in Object_Set) return Object_Set is
--
Working_Set : Object_Set := This_Set;
Copy_Set : Object_Set := Empty_Set;
--
begin
Directory_Tools.Object.Reset (Working_Set);
while (not Directory_Tools.Object.Done (Working_Set)) loop
Add (Directory_Tools.Object.Value (Working_Set), Copy_Set);
Directory_Tools.Object.Next (Working_Set);
end loop;
return (Copy_Set);
end Copy_Of;
--
function Is_Member (This_Set : in Object_Set; This_Object : in Object)
return Boolean is
begin
return (Directory_Tools.Object.Has (This_Set, This_Object));
end Is_Member;
--
procedure Add (This_Object : in Object; This_Set : in out Object_Set) is
--
Dummy : Boolean;
--
begin
if ((not Directory_Tools.Object.Is_Bad (This_Object)) and
(not Is_Member (This_Set, This_Object))) then
Directory_Tools.Object.Add (This_Set, This_Object, Dummy);
end if;
end Add;
--
procedure Remove (This_Object : in Object; This_Set : in out Object_Set) is
--
Dummy : Boolean;
--
begin
Directory_Tools.Object.Remove (This_Set, This_Object, Dummy);
end Remove;
--
procedure Sort (This_Set : in out Object_Set) is
--
type Sorted_Array is array (1 .. Number_In (This_Set)) of Boolean;
--
Already_Sorted : Sorted_Array := (others => False);
Remaining : Natural := Number_In (This_Set);
Sorted_Set : Object_Set := Empty_Set;
Smallest_This_Pass : Object;
Index_Of_Smallest : Natural;
Current_Index : Natural;
--
begin
while (Remaining > 0) loop
Current_Index := 1;
Directory_Tools.Object.Reset (This_Set);
Smallest_This_Pass := Directory_Tools.Object.Value (This_Set);
while (not Directory_Tools.Object.Done (This_Set)) loop
if (not Already_Sorted (Current_Index)) then
-- Current element hasn't already been put in
-- the sorted array, so test it.
if (Directory_Tools.Object.Value (This_Set) <
Smallest_This_Pass) then
-- Current element is smaller than the smallest
-- element found so far on this pass, so make
-- it the new smallest.
Smallest_This_Pass :=
Directory_Tools.Object.Value (This_Set);
Index_Of_Smallest := Current_Index;
end if;
end if;
Directory_Tools.Object.Next (This_Set);
Current_Index := Current_Index + 1;
end loop;
Add (Smallest_This_Pass, Sorted_Set);
Already_Sorted (Index_Of_Smallest) := True;
Remaining := Remaining - 1;
end loop;
This_Set := Sorted_Set;
end Sort;
--
procedure Filter (This_Set : in out Object_Set) is
--
New_Set : Object_Set := Empty_Set;
--
begin
Directory_Tools.Object.Reset (This_Set);
while (not Directory_Tools.Object.Done (This_Set)) loop
if (not Dont_Want (Directory_Tools.Object.Value (This_Set))) then
-- Want current object, so add it.
Add (Directory_Tools.Object.Value (This_Set), New_Set);
end if;
Directory_Tools.Object.Next (This_Set);
end loop;
This_Set := New_Set;
end Filter;
--
procedure Process_Objects (This_Set : in out Object_Set) is
begin
Directory_Tools.Object.Reset (This_Set);
while (not Directory_Tools.Object.Done (This_Set)) loop
declare
Current_Object : Object :=
Directory_Tools.Object.Value (This_Set);
begin
Process (Current_Object);
end;
Directory_Tools.Object.Next (This_Set);
end loop;
end Process_Objects;
--
procedure Process_Objects_With_State (This_Set : in out Object_Set;
This_State : in out Process_State) is
begin
Initialize (This_State);
Directory_Tools.Object.Reset (This_Set);
while (not Directory_Tools.Object.Done (This_Set)) loop
declare
Current_Object : Object :=
Directory_Tools.Object.Value (This_Set);
begin
Process (Current_Object, This_State);
end;
Directory_Tools.Object.Next (This_Set);
end loop;
Finalize (This_State);
end Process_Objects_With_State;
--
function Union (This_Set : in Object_Set; That_Set : in Object_Set)
return Object_Set is
--
Union_Set : Object_Set := Empty_Set;
--
procedure Union_Copy (This_Set : in Object_Set;
New_Set : in out Object_Set) is
--
Working_Set : Object_Set := This_Set;
--
begin
Directory_Tools.Object.Reset (Working_Set);
while (not Directory_Tools.Object.Done (Working_Set)) loop
Add (Directory_Tools.Object.Value (Working_Set), New_Set);
Directory_Tools.Object.Next (Working_Set);
end loop;
end Union_Copy;
--
begin
Union_Copy (This_Set, Union_Set);
Union_Copy (That_Set, Union_Set);
return (Union_Set);
end Union;
--
function Intersection (This_Set : in Object_Set; That_Set : in Object_Set)
return Object_Set is
--
Working_Set : Object_Set := This_Set;
Intersection_Set : Object_Set := Empty_Set;
--
begin
Directory_Tools.Object.Reset (Working_Set);
while (not Directory_Tools.Object.Done (Working_Set)) loop
if (Is_Member (That_Set,
Directory_Tools.Object.Value (Working_Set))) then
-- Found an object in the one set which is also in the
-- other set, so add it to the intersection set.
Add (Directory_Tools.Object.Value (Working_Set),
Intersection_Set);
end if;
Directory_Tools.Object.Next (Working_Set);
end loop;
return (Intersection_Set);
end Intersection;
--
function Exclusive_Or (This_Set : in Object_Set; That_Set : in Object_Set)
return Object_Set is
--
Xor_Set : Object_Set := Empty_Set;
--
procedure Xor_Copy (This_Set : in Object_Set;
Except_For : in Object_Set;
Into : in out Object_Set) is
--
Working_Set : Object_Set := This_Set;
--
begin
Directory_Tools.Object.Reset (Working_Set);
while (not Directory_Tools.Object.Done (Working_Set)) loop
if (not Is_Member (Except_For, Directory_Tools.Object.Value
(Working_Set))) then
-- Found an object in the one set which is not also
-- in the other set, so add it to the new set.
Add (Directory_Tools.Object.Value (Working_Set), Into);
end if;
Directory_Tools.Object.Next (Working_Set);
end loop;
end Xor_Copy;
--
begin
Xor_Copy (This_Set, That_Set, Xor_Set);
Xor_Copy (That_Set, This_Set, Xor_Set);
return (Xor_Set);
end Exclusive_Or;
--
function Subtraction (This_Set : in Object_Set; Except_For : in Object_Set)
return Object_Set is
--
Working_Set : Object_Set := This_Set;
Subtraction_Set : Object_Set := Empty_Set;
--
begin
Directory_Tools.Object.Reset (Working_Set);
while (not Directory_Tools.Object.Done (Working_Set)) loop
if (not Is_Member (Except_For,
Directory_Tools.Object.Value (Working_Set))) then
-- Found an object in the one set which is not also
-- in the other set, so add it to the subtraction set.
Add (Directory_Tools.Object.Value (Working_Set),
Subtraction_Set);
end if;
Directory_Tools.Object.Next (Working_Set);
end loop;
return (Subtraction_Set);
end Subtraction;
--
function Subset (This_Set : in Object_Set; Contains : in Object_Set)
return Boolean is
--
Working_Set : Object_Set := Contains;
Result : Boolean := True;
--
begin
Directory_Tools.Object.Reset (Working_Set);
while (not Directory_Tools.Object.Done (Working_Set)) loop
if (not Is_Member (This_Set,
Directory_Tools.Object.Value (Working_Set))) then
-- Found an object in "Contains" which is not in the
-- other set, so is not a subset of the other set.
Result := False;
exit;
end if;
Directory_Tools.Object.Next (Working_Set);
end loop;
return (Result);
end Subset;
--
function Proper_Subset (This_Set : in Object_Set; Contains : in Object_Set)
return Boolean is
begin
return (Subset (This_Set, Contains) and
(Number_In (This_Set) > Number_In (Contains)));
end Proper_Subset;
--
function Is_Universe_Mirror (This_Unit : in Object) return Boolean is
--
-- Diana hacking because no predicate is available.
--
The_Root : Directory.Ada.Root;
The_Status : Directory.Error_Status;
Object_Id : Diana.Tree;
Pragmas : Diana.Sequence;
--
Is_Subsystem_Interface : Boolean := False;
Has_Module_Name : Boolean := False;
--
begin
-- Find the root of the object.
Directory_Tools.Object.Low_Level.Get_Root
(This_Unit, The_Root, The_Status);
-- Get the id for the object.
Object_Id := Diana.Id_Utilities.Comp_Unit_Id (The_Root);
-- See if is a subsystem interface.
Is_Subsystem_Interface :=
Semantic_Attributes.Has_Sm_Subsystem_Interface (Object_Id);
if (Is_Subsystem_Interface) then
-- Since is subsystem interface, see if has a pragma
-- for Module_Name in it: if so, it is a universe mirror.
Pragmas := Semantic_Attributes.Sm_Applied_Pragmas (Object_Id);
while (not Diana.Is_Empty (Pragmas)) loop
if (String_Utilities.Upper_Case
(Diana.Image (Diana.Id
(Diana.As_Id (Diana.Head (Pragmas))))) =
"MODULE_NAME") then
Has_Module_Name := True;
exit;
end if;
Pragmas := Diana.Tail (Pragmas);
end loop;
end if;
return (Is_Subsystem_Interface and Has_Module_Name);
end Is_Universe_Mirror;
--
function Is_Spec (This_Object : in Object) return Boolean is
begin
return (Directory_Tools.Ada_Object.Is_Visible_Part (This_Object));
end Is_Spec;
--
procedure Screen (These_Units : in out Object_Set;
Exclude : in Object_Set;
Specs_Only : in Boolean;
Include_Universe_Mirrors : in Boolean) is
--
Screened : Object_Set := Empty_Set;
--
Current : Object;
--
begin
Directory_Tools.Object.Reset (These_Units);
while (not Directory_Tools.Object.Done (These_Units)) loop
Current := Directory_Tools.Object.Value (These_Units);
if (Directory_Tools.Object.Is_Bad (Current)) then
-- Current unit is bad, so don't add it.
null;
elsif (Directory_Tools.Object.Has (Exclude, Current)) then
-- Already have the current unit, so don't add it.
null;
elsif ((Specs_Only) and then (not Is_Spec (Current))) then
-- Client wants specs only, and current unit is not a spec,
-- so don't add it.
null;
elsif ((not Include_Universe_Mirrors) and then
(Is_Universe_Mirror (Current))) then
-- Client doesn't want universe mirrors, and current unit is
-- a universe mirror, so don't add it.
null;
else
-- Current unit met all criteria, so add it.
Add (Current, Screened);
end if;
Directory_Tools.Object.Next (These_Units);
end loop;
These_Units := Screened;
end Screen;
--
generic
with function Immediate_Dependencies
(This_Object : in Object;
Code_Share_Generics : in Boolean;
This_Activity : in Activity.Activity_Name)
return Object_Set;
function Single_Unit_Dependency_Closure
(Unit : in Object;
Specs_Only : in Boolean := False;
Transitive : in Boolean := True;
Include_Universe_Mirrors : in Boolean := False;
Code_Share_Generics : in Boolean := True;
This_Activity : in Activity.Activity_Name := Activity.Nil)
return Object_Set;
function Single_Unit_Dependency_Closure
(Unit : in Object;
Specs_Only : in Boolean := False;
Transitive : in Boolean := True;
Include_Universe_Mirrors : in Boolean := False;
Code_Share_Generics : in Boolean := True;
This_Activity : in Activity.Activity_Name := Activity.Nil)
return Object_Set is
--
Closure : Object_Set := Empty_Set;
New_Units : Object_Set := Empty_Set;
--
procedure Get_Next_Units (These_Units : in out Object_Set) is
--
New_Units : Object_Set := Empty_Set;
--
begin
Directory_Tools.Object.Reset (These_Units);
while (not Directory_Tools.Object.Done (These_Units)) loop
New_Units := New_Units +
Immediate_Dependencies
(Directory_Tools.Object.Value (These_Units),
Code_Share_Generics, This_Activity);
Directory_Tools.Object.Next (These_Units);
end loop;
These_Units := New_Units;
end Get_Next_Units;
--
begin
New_Units := Immediate_Dependencies
(Unit, Code_Share_Generics, This_Activity);
loop
Screen (New_Units, Closure, Specs_Only, Include_Universe_Mirrors);
Closure := Closure + New_Units;
if (not Transitive) then
-- Only needed to calculate first level.
exit;
elsif (Is_Empty (New_Units)) then
-- There were no new units, so closure is complete.
exit;
else
-- There are more units requiring processing.
Get_Next_Units (New_Units);
end if;
end loop;
return (Closure);
end Single_Unit_Dependency_Closure;
--
generic
with function Single_Unit_Dependency_Closure_Instantiation
(Unit : in Object;
Specs_Only : in Boolean := False;
Transitive : in Boolean := True;
Include_Universe_Mirrors : in Boolean := False;
Code_Share_Generics : in Boolean := True;
This_Activity : in
Activity.Activity_Name := Activity.Nil)
return Object_Set;
function Multiple_Unit_Dependency_Closure
(Units : in Object_Set;
Specs_Only : in Boolean := False;
Transitive : in Boolean := True;
Include_Universe_Mirrors : in Boolean := False;
Code_Share_Generics : in Boolean := True;
This_Activity : in Activity.Activity_Name := Activity.Nil)
return Object_Set;
function Multiple_Unit_Dependency_Closure
(Units : in Object_Set;
Specs_Only : in Boolean := False;
Transitive : in Boolean := True;
Include_Universe_Mirrors : in Boolean := False;
Code_Share_Generics : in Boolean := True;
This_Activity : in Activity.Activity_Name := Activity.Nil)
return Object_Set is
--
Working_Set : Object_Set := Units;
Closure : Object_Set := Empty_Set;
--
begin
Directory_Tools.Object.Reset (Working_Set);
while (not Directory_Tools.Object.Done (Working_Set)) loop
Closure := Closure + Single_Unit_Dependency_Closure_Instantiation
(Directory_Tools.Object.Value (Working_Set),
Specs_Only, Transitive,
Include_Universe_Mirrors,
Code_Share_Generics, This_Activity);
Directory_Tools.Object.Next (Working_Set);
end loop;
return (Closure);
end Multiple_Unit_Dependency_Closure;
--
-- ***** UNTIL NEXT MARK LIKE THIS, CAN BE REPLACED BY OBJECT_INFO.
--
function Subclasses_Equal
(This_Object : in Object; This_Subclass : in Directory.Subclass)
return Boolean is
--
function "=" (This_Subclass : in Directory.Subclass;
That_Subclass : in Directory.Subclass) return Boolean
renames Directory."=";
--
function "=" (This_Error_Status : in Directory.Error_Status;
That_Error_Status : in Directory.Error_Status)
return Boolean renames Directory."=";
--
The_Object : Directory.Object;
The_Subclass : Directory.Subclass;
The_Status : Directory.Error_Status;
--
begin
Directory_Tools.Object.Low_Level.Get_Object
(This_Object, The_Object, The_Status);
The_Subclass := Directory.Get_Subclass (The_Object);
return ((The_Status = Directory.Successful) and
(The_Subclass = This_Subclass));
end Subclasses_Equal;
--
function Is_Spec_View (This_Object : in Directory_Tools.Object.Handle)
return Boolean is
begin
return (Subclasses_Equal (This_Object,
Object_Subclass.Spec_View_Subclass));
end Is_Spec_View;
--
function Is_Load_View (This_Object : in Directory_Tools.Object.Handle)
return Boolean is
begin
return (Subclasses_Equal (This_Object,
Object_Subclass.Load_View_Subclass));
end Is_Load_View;
--
generic
with function Is_Correct_Kind
(This_Library : in Directory_Tools.Object.Handle)
return Boolean;
function Is_Enclosed (This_Object : in Object) return Boolean;
--
function Is_Enclosed (This_Object : in Object) return Boolean is
--
-- This function finds successive enclosing libraries of the original
-- object and tests each one to determine if it is the correct kind
-- or not.
--
Current_Library : Object;
--
Result : Boolean := False;
--
begin
if (Directory_Tools.Naming.Full_Name (This_Object) = "!") then
-- Cannot be contained by anything, because already at root.
Result := False;
else
Current_Library := Directory_Tools.Traversal.
Enclosing_Library (This_Object);
loop
if (Is_Correct_Kind (Current_Library)) then
-- Found an enclosing library of the correct kind.
Result := True;
exit;
elsif (Directory_Tools.Naming.
Full_Name (Current_Library) = "!") then
-- Worked our way all the way up to the root without finding
-- an enclosing object of the correct kind.
exit;
else
-- Keep looking.
Current_Library := Directory_Tools.Traversal.
Enclosing_Library (Current_Library);
end if;
end loop;
end if;
return (Result);
end Is_Enclosed;
--
function Is_Enclosed_By_Spec_View is new Is_Enclosed (Is_Spec_View);
function Is_Contained_By_Spec_View
(This_Object : in Directory_Tools.Object.Handle)
return Boolean is
begin
return (Is_Enclosed_By_Spec_View (This_Object));
end Is_Contained_By_Spec_View;
--
function Is_Enclosed_By_Load_View is new Is_Enclosed (Is_Load_View);
--
function Is_Contained_By_Load_View
(This_Object : in Directory_Tools.Object.Handle)
return Boolean is
begin
return (Is_Enclosed_By_Load_View (This_Object));
end Is_Contained_By_Load_View;
--
-- ****** END OF STUFF THAT CAN BE REPLACED BY OBJECT_INFO.
-- ****** SOME OF THE STUFF BELOW SHOULD BE ADDED TO OBJECT_INFO.
--
function Is_Spec_In_Spec_View (This_Object : in Object) return Boolean is
--
-- Returns True if the specified object is a spec in a view.
--
begin
return ((Is_Spec (This_Object)) and then
(Is_Contained_By_Spec_View (This_Object)));
end Is_Spec_In_Spec_View;
--
function Is_Spec_In_Load_View (This_Object : in Object) return Boolean is
--
-- Returns True if the specified object is a spec in a view.
--
begin
return ((Is_Spec (This_Object)) and then
(Is_Contained_By_Load_View (This_Object)));
end Is_Spec_In_Load_View;
--
function Is_Subsystem (This_Object : in Object) return Boolean is
begin
return ((Subclasses_Equal
(This_Object, Object_Subclass.Subsystem_Subclass)) or
(Subclasses_Equal
(This_Object, Object_Subclass.
Spec_Load_Subsystem_Subclass)) or
(Subclasses_Equal
(This_Object, Object_Subclass.
Combined_Subsystem_Subclass)));
end Is_Subsystem;
--
function Is_Root (This_Object : in Object) return Boolean is
begin
return (Directory_Tools.Naming.Full_Name (This_Object) = "!");
end Is_Root;
--
function Bogus_Object return Object is
begin
return (Directory_Tools.Naming.Resolution ("%*$&"));
end Bogus_Object;
--
function Subsystem_Containing (This_Object : in Object) return Object is
--
Current_Library : Object := This_Object;
--
begin
loop
if (Is_Root (Current_Library)) then
Current_Library := Bogus_Object;
exit;
else
Current_Library := Directory_Tools.Traversal.Enclosing_Library
(Current_Library);
if (Is_Subsystem (Current_Library)) then
-- Found the enclosing subsystem.
exit;
end if;
end if;
end loop;
return (Current_Library);
end Subsystem_Containing;
--
function Spec_In_Other_View
(This_Object : in Object;
This_Activity : in Activity.Activity_Name) return Object is
--
-- If the specified object is a spec in a view, returns the spec
-- associated with it in the other view, as specified by the
-- activity. If no such spec exists, returns a bogus object.
--
Subsystem_Id : Activity_Implementation.Subsystem_Id;
Activity_Id : Activity_Implementation.Activity_Id;
Activity_Handle : Activity_Implementation.Activity_Handle;
Name_Status : Directory.Naming.Name_Status;
Error_Status : Directory.Error_Status;
Current_View : Directory.Object;
Other_View : Directory.Object;
Other_Spec : Object := Bogus_Object;
--
function Spec_Matching
(Current_Spec : in Object;
View_Containing_Current_Spec : in Directory.Object;
View_Containing_Other_Spec : in Directory.Object)
return Object is
--
Name_Of_View_Containing_Current_Spec : constant String :=
Directory.Naming.Get_Full_Name (View_Containing_Current_Spec);
Name_Of_View_Containing_Other_Spec : constant String :=
Directory.Naming.Get_Full_Name (View_Containing_Other_Spec);
Name_Of_Current_Spec : constant String :=
Directory_Tools.Naming.Full_Name (Current_Spec);
Name_Of_Other_Spec : constant String :=
Name_Of_View_Containing_Other_Spec &
Name_Of_Current_Spec
((Name_Of_Current_Spec'First +
Name_Of_View_Containing_Current_Spec'Length) ..
Name_Of_Current_Spec'Last);
--
begin
return (Directory_Tools.Naming.Resolution (Name_Of_Other_Spec));
end Spec_Matching;
--
begin
Directory.Naming.Resolve
(Name => Directory_Tools.Naming.Full_Name
(Subsystem_Containing (This_Object)),
The_Object => Subsystem_Id,
Status => Name_Status);
Directory.Naming.Resolve (Name => This_Activity,
The_Object => Activity_Id,
Status => Name_Status);
Activity_Implementation.Open
(Activity_Id, Activity_Handle, Error_Status);
if (Is_Spec_In_Spec_View (This_Object)) then
Current_View := Activity_Implementation.Get_Spec_View
(Subsystem_Id, Activity_Handle);
Other_View := Activity_Implementation.Get_Load_View
(Subsystem_Id, Activity_Handle);
Other_Spec := Spec_Matching (This_Object, Current_View, Other_View);
elsif (Is_Spec_In_Load_View (This_Object)) then
Current_View := Activity_Implementation.Get_Load_View
(Subsystem_Id, Activity_Handle);
Other_View := Activity_Implementation.Get_Spec_View
(Subsystem_Id, Activity_Handle);
Other_Spec := Spec_Matching (This_Object, Current_View, Other_View);
end if;
Activity_Implementation.Close (Activity_Handle, Error_Status);
return (Other_Spec);
--
exception
when others =>
return (Other_Spec);
--
end Spec_In_Other_View;
--
function Spec_For (This_Object : in Object) return Object is
--
-- For a subunit or body, returns the spec associated with
-- the subunit or body. For a spec, returns the spec itself.
--
Current_Object : Object := This_Object;
--
begin
-- First, find parents transitively until get to body.
while (Directory_Tools.Ada_Object.Is_Subunit (Current_Object)) loop
Current_Object := Directory_Tools.Traversal.Parent (Current_Object);
end loop;
if (not Is_Spec (Current_Object)) then
-- Find spec associated with body.
Current_Object :=
Directory_Tools.Ada_Object.Other_Part (Current_Object);
end if;
return (Current_Object);
end Spec_For;
--
function Is_Body (This_Object : in Object) return Boolean is
--
-- Returns True if the specified object is a body.
--
Unit_Kind : Directory_Tools.Ada_Object.Unit_Kind :=
Directory_Tools.Ada_Object.Kind (This_Object);
--
begin
return ((Unit_Kind = Directory_Tools.Ada_Object.Package_Body) or
(Unit_Kind = Directory_Tools.Ada_Object.Procedure_Body) or
(Unit_Kind = Directory_Tools.Ada_Object.Function_Body));
end Is_Body;
--
function Is_Subunit (This_Object : in Object) return Boolean is
--
-- Returns True if the specified object is a subunit.
--
Compilation_Kind : Directory_Tools.Ada_Object.Compilation_Kind :=
Directory_Tools.Ada_Object.Kind (This_Object);
--
begin
return (Compilation_Kind = Directory_Tools.Ada_Object.Subunit);
end Is_Subunit;
--
function Is_Body_Or_Subunit (This_Object : in Object) return Boolean is
--
-- Returns True if the specified object is a body or subunit.
--
begin
return ((Is_Body (This_Object)) or (Is_Subunit (This_Object)));
end Is_Body_Or_Subunit;
--
function Is_Generic_Spec (This_Object : in Object) return Boolean is
--
-- Returns True if the spec specified object is a generic spec.
--
Object_Kind : Directory_Tools.Ada_Object.Unit_Kind :=
Directory_Tools.Ada_Object.Kind (This_Object);
--
begin
return ((Is_Spec (This_Object)) and then
((Object_Kind = Directory_Tools.Ada_Object.
Generic_Package) or
(Object_Kind = Directory_Tools.Ada_Object.Generic_Procedure) or
(Object_Kind = Directory_Tools.Ada_Object.Generic_Function)));
end Is_Generic_Spec;
--
function Spec_Is_Generic_For (This_Object : in Object) return Boolean is
--
-- Returns True if the spec associated with the specified object
-- is a generic spec.
--
begin
return (Is_Generic_Spec (Spec_For (This_Object)));
end Spec_Is_Generic_For;
--
function Immediate_Dependencies_On
(This_Object : in Object;
Code_Share_Generics : in Boolean;
This_Activity : in Activity.Activity_Name) return Object_Set is
--
Dependencies : Object_Set :=
Directory_Tools.Ada_Object.Depends_On (This_Object);
--
begin
-- Deal with question of code sharing.
if ((not Code_Share_Generics) and then
(Is_Body_Or_Subunit (This_Object)) and then
(Spec_Is_Generic_For (This_Object))) then
-- Current object is body or subunit associated with
-- a generic spec, and generic bodies are not code-shared.
-- Therefore, the current object will be macro-
-- inline expanded, and dependencies on the current
-- object include dependencies on its spec.
Dependencies := Dependencies + Directory_Tools.Ada_Object.Depends_On
(Spec_For (This_Object));
end if;
-- Perform spec look-through.
if (Is_Spec_In_Load_View (This_Object)) then
-- The object is a spec in a load view, so it has an associated spec
-- in a spec view. Anything that depends on the spec in the spec view
-- in actuality depends on the current object, so add the spec view
-- spec to the dependencies (so that the next pass will get the
-- dependencies on it).
Add (Spec_In_Other_View (This_Object, This_Activity), Dependencies);
end if;
return (Dependencies);
end Immediate_Dependencies_On;
--
function Dependencies_On_Single_Unit is
new Single_Unit_Dependency_Closure (Immediate_Dependencies_On);
--
function Dependencies_On
(Unit : in Object;
Specs_Only : in Boolean := False;
Transitive : in Boolean := True;
Include_Universe_Mirrors : in Boolean := False;
Code_Share_Generics : in Boolean := True;
This_Activity : in Activity.Activity_Name := Activity.Nil)
return Object_Set is
begin
return (Dependencies_On_Single_Unit
(Unit, Specs_Only, Transitive, Include_Universe_Mirrors,
Code_Share_Generics, This_Activity));
end Dependencies_On;
--
function Dependencies_On_Multiple_Units is
new Multiple_Unit_Dependency_Closure (Dependencies_On);
--
function Dependencies_On
(Units : in Object_Set;
Specs_Only : in Boolean := False;
Transitive : in Boolean := True;
Include_Universe_Mirrors : in Boolean := False;
Code_Share_Generics : in Boolean := True;
This_Activity : in Activity.Activity_Name := Activity.Nil)
return Object_Set is
begin
return (Dependencies_On_Multiple_Units
(Units, Specs_Only, Transitive, Include_Universe_Mirrors,
Code_Share_Generics, This_Activity));
end Dependencies_On;
--
function Immediate_Dependencies_By
(This_Object : in Object;
Code_Share_Generics : in Boolean;
This_Activity : in Activity.Activity_Name) return Object_Set is
--
Dependencies : Object_Set := Withed_Objects (This_Object);
--
Families_Of_Generic_Specs : Object_Set := Empty_Set;
--
Specs_In_Load_Views : Object_Set := Empty_Set;
--
begin
-- Deal with bodies and subunits.
if (Is_Subunit (This_Object)) then
Add (Directory_Tools.Traversal.Parent (This_Object), Dependencies);
elsif (Is_Body (This_Object)) then
Add (Directory_Tools.Ada_Object.Other_Part (This_Object),
Dependencies);
end if;
-- Deal with question of code sharing.
if (not Code_Share_Generics) then
Directory_Tools.Object.Reset (Dependencies);
while (not Directory_Tools.Object.Done (Dependencies)) loop
if (Is_Generic_Spec (Directory_Tools.Object.Value
(Dependencies))) then
-- The object depends on a generic spec. Since the body and
-- subunits of the generic spec are not code-shared, they
-- will be macro-inline expanded. Therefore, the object
-- depends on the entire family of the generic spec.
Families_Of_Generic_Specs :=
Families_Of_Generic_Specs +
Family (Directory_Tools.Object.Value (Dependencies));
end if;
Directory_Tools.Object.Next (Dependencies);
end loop;
end if;
Dependencies := Dependencies + Families_Of_Generic_Specs;
-- Perform spec look-through.
Directory_Tools.Object.Reset (Dependencies);
while (not Directory_Tools.Object.Done (Dependencies)) loop
if (Is_Spec_In_Spec_View
(Directory_Tools.Object.Value (Dependencies))) then
-- The object depends on a spec in a spec view. So add
-- the associated spec in the load view to the dependencies.
Add (Spec_In_Other_View
(Directory_Tools.Object.Value (Dependencies),
This_Activity), Specs_In_Load_Views);
end if;
Directory_Tools.Object.Next (Dependencies);
end loop;
Dependencies := Dependencies + Specs_In_Load_Views;
return (Dependencies);
end Immediate_Dependencies_By;
--
function Dependencies_By_Single_Unit is
new Single_Unit_Dependency_Closure (Immediate_Dependencies_By);
--
function Dependencies_By
(Unit : in Object;
Specs_Only : in Boolean := False;
Transitive : in Boolean := True;
Include_Universe_Mirrors : in Boolean := False;
Code_Share_Generics : in Boolean := True;
This_Activity : in Activity.Activity_Name := Activity.Nil)
return Object_Set is
begin
return (Dependencies_By_Single_Unit
(Unit, Specs_Only, Transitive, Include_Universe_Mirrors,
Code_Share_Generics, This_Activity));
end Dependencies_By;
--
function Dependencies_By_Multiple_Units is
new Multiple_Unit_Dependency_Closure (Dependencies_By);
--
function Dependencies_By
(Units : in Object_Set;
Specs_Only : in Boolean := False;
Transitive : in Boolean := True;
Include_Universe_Mirrors : in Boolean := False;
Code_Share_Generics : in Boolean := True;
This_Activity : in Activity.Activity_Name := Activity.Nil)
return Object_Set is
begin
return (Dependencies_By_Multiple_Units
(Units, Specs_Only, Transitive, Include_Universe_Mirrors,
Code_Share_Generics, This_Activity));
end Dependencies_By;
--
function Withed_Objects (Unit : in Object) return Object_Set is
begin
return (Directory_Tools.Ada_Object.List_Of_Withs (Unit));
end Withed_Objects;
--
function Immediate_Family_Dependencies_On
(This_Object : in Object;
Code_Share_Generics : in Boolean;
This_Activity : in Activity.Activity_Name) return Object_Set is
--
Dependencies : Object_Set := Directory_Tools.Ada_Object.Subunits
(This_Object, Declared => False);
--
begin
if (Is_Spec (This_Object)) then
-- Add body.
Add (Directory_Tools.Ada_Object.Other_Part (This_Object),
Dependencies);
-- Add subunits.
Dependencies :=
Dependencies + Directory_Tools.Ada_Object.Subunits
(Directory_Tools.Ada_Object.Other_Part
(This_Object));
-- Perform spec look-through.
if (Is_Spec_In_Spec_View (This_Object)) then
Add (Spec_In_Other_View (This_Object, This_Activity),
Dependencies);
end if;
elsif (Is_Body_Or_Subunit (This_Object)) then
-- Add subunits.
Dependencies :=
Dependencies + Directory_Tools.Ada_Object.Subunits (This_Object);
end if;
return (Dependencies);
end Immediate_Family_Dependencies_On;
--
function Family_Dependencies_On is
new Single_Unit_Dependency_Closure (Immediate_Family_Dependencies_On);
--
function Family (Unit : in Object;
This_Activity : in Activity.Activity_Name := Activity.Nil)
return Object_Set is
--
Family_Dependencies : Object_Set :=
Family_Dependencies_On (Unit,
Specs_Only => False,
Transitive => True,
Include_Universe_Mirrors => True,
Code_Share_Generics => True,
This_Activity => This_Activity);
--
begin
Add (Unit, Family_Dependencies);
return (Family_Dependencies);
end Family;
--
end Object_Sets;