|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 126417 (0x1edd1)
Types: TextFile
Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦d88fb0bd5⟧
└─⟦this⟧
WITH Activity;
PROCEDURE Dependency_Analysis
(The_Objects : IN String := "<SELECTION>";
Show_Full_Pathnames : Boolean := False;
Show_Dependencies_Only : IN Boolean := True;
Process_Specs_Only : IN Boolean := False;
Process_Using_Transitive_Closure : IN Boolean := False;
Include_Environment_Dependencies : IN Boolean := False;
Analyze_Generics_As_Code_Shared : IN Boolean := True;
Use_This_Activity : IN Activity.Activity_Name := Activity.Nil);
--
-- The_Objects:
--
-- This parameter provides the set of directory objects upon which to
-- perform the dependency analysis. The parameter must resolve to at
-- least one object.
--
-- Show_Full_Pathnames:
--
-- When this parameter is True, all object names will be presented as full
-- pathnames.
--
-- Show_Dependencies_Only:
-- When this parameter is False the units that depend upon The_Object
-- will be shown (in addition to the units that The_Object depends upon --
-- i.e. "withs").
--
-- Process_Specs_Only:
--
-- When this parameter is True, only Ada specs will be included.
--
-- Process_Using_Transitive_Closure:
--
-- When this parameter is True, an object set will be generated using
-- transitive closure rules (i.e. if 'A' depends upon 'B', and 'B' depends
-- upon 'C', then 'A' depends upon 'C', transitively).
--
-- Include_Environment_Dependencies:
--
-- When this parameter is True, Ada specs which are an integral part of
-- the Rational Environment will be included.
--
-- Analyze_Generics_As_Code_Shared;
--
-- When this parameter is True, generic instantiations will be analyzed
-- using a code-sharing model (e.g. as on the R1000).
--
-- When this parameter is False, generic instantiations will be analyzed
-- using a macro in-line expansion model (e.g. as on a VAX).
--
-- Use_This_Activity:
--
-- This parameter allows the client to specify which activity should be
-- used when subsystems are involved. In the default case, the activity
-- is empty and dependency analysis will not cross view boundaries.
WITH Activity;
WITH Directory_Tools;
WITH Io;
WITH Object_Sets;
WITH Object_Sets_Renames;
USE Object_Sets_Renames;
PROCEDURE Dependency_Analysis
(The_Objects : IN String := "<SELECTION>";
Show_Full_Pathnames : Boolean := False;
Show_Dependencies_Only : IN Boolean := True;
Process_Specs_Only : IN Boolean := False;
Process_Using_Transitive_Closure : IN Boolean := False;
Include_Environment_Dependencies : IN Boolean := False;
Analyze_Generics_As_Code_Shared : IN Boolean := True;
Use_This_Activity : IN Activity.Activity_Name := Activity.Nil) IS
PACKAGE Dir_Object RENAMES Directory_Tools.Object;
PACKAGE Dir_Names RENAMES Directory_Tools.Naming;
All_Objects : Dir_Object.Iterator := Dir_Names.Resolution (The_Objects);
FUNCTION Simple_Name (The_Object : IN Dir_Object.Handle) RETURN String IS
BEGIN
RETURN (Dir_Names.Simple_Name (The_Object) &
Dir_Names.Part_Attribute
(Dir_Names.Unique_Full_Name (The_Object)));
END Simple_Name;
PROCEDURE Print_Objects (These_Objects : IN Object_Set;
Show_Full_Pathnames : IN Boolean;
This_Header : IN String) IS
Indentation : CONSTANT String := " ";
Underline : CONSTANT String (This_Header'First .. This_Header'Last) :=
(OTHERS => '-');
The_Objects : Object_Set := These_Objects;
BEGIN
Dir_Object.Reset (The_Objects);
IF (Dir_Object.Done (The_Objects)) THEN
NULL;
ELSE
Io.Put_Line (This_Header);
Io.Put_Line (Underline);
WHILE (NOT Dir_Object.Done (The_Objects)) LOOP
IF Show_Full_Pathnames THEN
Io.Put_Line (Indentation & Dir_Names.Unique_Full_Name
(Dir_Object.Value (The_Objects)));
ELSE
Io.Put_Line (Indentation & Simple_Name
(Dir_Object.Value (The_Objects)));
END IF;
Dir_Object.Next (The_Objects);
END LOOP;
END IF;
Io.New_Line;
END Print_Objects;
BEGIN
IF Dir_Object.Is_Bad (All_Objects) THEN
Io.Put_Line ("CANNOT RESOLVE """ & The_Objects & """!");
END IF;
WHILE NOT Dir_Object.Done (All_Objects) LOOP
DECLARE
This_Object : Object := Dir_Object.Value (All_Objects);
Full_Object_Name : CONSTANT String :=
Dir_Names.Unique_Full_Name (This_Object);
Simple_Object_Name : CONSTANT String :=
Dir_Names.Simple_Name (This_Object) &
Dir_Names.Part_Attribute
(Dir_Names.Unique_Full_Name (This_Object));
BEGIN
IF (Dir_Object.Is_Bad (This_Object)) THEN
Io.Put_Line ("CANNOT RESOLVE """ & The_Objects & """!");
ELSE
IF Show_Dependencies_Only THEN
NULL;
ELSE
IF Show_Full_Pathnames THEN
Print_Objects (These_Objects =>
Object_Sets.Dependencies_On
(This_Object, Process_Specs_Only,
Process_Using_Transitive_Closure,
Include_Environment_Dependencies,
Analyze_Generics_As_Code_Shared,
Use_This_Activity),
Show_Full_Pathnames => True,
This_Header =>
"The following depend upon (""with"") " &
Full_Object_Name & ":");
ELSE
Print_Objects (These_Objects =>
Object_Sets.Dependencies_On
(This_Object, Process_Specs_Only,
Process_Using_Transitive_Closure,
Include_Environment_Dependencies,
Analyze_Generics_As_Code_Shared,
Use_This_Activity),
Show_Full_Pathnames => False,
This_Header =>
"The following depend upon (""with"") " &
Simple_Object_Name & ":");
END IF;
END IF;
IF Show_Full_Pathnames THEN
Print_Objects (These_Objects =>
Object_Sets.Dependencies_By
(This_Object, Process_Specs_Only,
Process_Using_Transitive_Closure,
Include_Environment_Dependencies,
Analyze_Generics_As_Code_Shared,
Use_This_Activity),
Show_Full_Pathnames => True,
This_Header => Full_Object_Name &
" depends upon (""withs""):");
ELSE
Print_Objects (These_Objects =>
Object_Sets.Dependencies_By
(This_Object, Process_Specs_Only,
Process_Using_Transitive_Closure,
Include_Environment_Dependencies,
Analyze_Generics_As_Code_Shared,
Use_This_Activity),
Show_Full_Pathnames => False,
This_Header => Simple_Object_Name &
" depends upon (""withs""):");
END IF;
END IF;
Dir_Object.Next (All_Objects);
END;
END LOOP;
END Dependency_Analysis;WITH Directory;
WITH Directory_Tools;
PACKAGE Object_Info IS
-- This package provides information about objects in the Environment.
-- This package consists of several sub-packages, each of which is
-- dedicated to a particular kind of object.
--
-- A few terms need definition:
--
-- "Simple world" : a world that is not a subsystem or view.
-- "Simple object": an object that is not a library.
--
-- If "Recursive" is True, the objects in "This_Object.@??" will be
-- analyzed. If "Recursive" is False, only the objects in "This_Object.
-- @" will be analyzed.
PACKAGE Any IS
-- This package provides information applicable to any object in
-- the Environment.
FUNCTION Number_Of_Objects_In
(This_Iterator : IN Directory_Tools.Object.Iterator)
RETURN Natural;
FUNCTION Number_Of_Objects_Enclosed_By
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Natural;
FUNCTION Classes_Equal
(This_Object : IN Directory_Tools.Object.Handle;
This_Class : IN Directory_Tools.Object.Class_Enumeration)
RETURN Boolean;
FUNCTION Subclasses_Equal
(This_Object : IN Directory_Tools.Object.Handle;
This_Subclass : IN Directory.Subclass) RETURN Boolean;
FUNCTION Is_Good (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Bad (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Library (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Directory (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_World (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Simple_World (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Subsystem (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_View (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Spec_View (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Load_View (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Regular_Load_View
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Coded_Load_View
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Combined_View
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Simple_Object
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Ada_Unit (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_File (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Misc_Simple_Object
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Frozen (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Contains_Libraries
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Contains_Directories
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Contains_Worlds (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Contains_Simple_Worlds
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Contains_Subsystems
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Contains_Views (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Contains_Spec_Views
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Contains_Load_Views
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Contains_Regular_Load_Views
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Contains_Coded_Load_Views
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Contains_Combined_Views
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Contains_Simple_Objects
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Contains_Ada_Units
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Contains_Files (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Contains_Misc_Simple_Objects
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Contains_Frozen_Objects
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Is_Contained_By_Subsystem
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Contained_By_View
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Contained_By_Spec_View
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Contained_By_Load_View
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Contained_By_Units_Directory_Of_View
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION All_Objects_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Libraries_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Directories_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Worlds_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Simple_Worlds_In (This_Object : IN
Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Subsystems_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Views_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Spec_Views_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Load_Views_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Regular_Load_Views_In
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Coded_Load_Views_In (This_Object : IN
Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Combined_Views_In (This_Object : IN
Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Simple_Objects_In (This_Object : IN
Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Ada_Units_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Files_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Misc_Simple_Objects_In
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Frozen_Objects_In (This_Object : IN
Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
END Any;
PACKAGE Cmvc IS
-- This package provides information about objects under CMVC.
FUNCTION Models_Equal
(This_View : IN Directory_Tools.Object.Handle;
This_Model : IN String := "!MODEL.R1000") RETURN Boolean;
FUNCTION Is_Controlled (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Checked_Out (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Contains_Controlled_Objects
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Contains_Checked_Out_Objects
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean;
FUNCTION Controlled_Objects_In
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
FUNCTION Checked_Out_Objects_In
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator;
END Cmvc;
END Object_Info;WITH Object_Set;
WITH Object_Subclass;
WITH String_Utilities;
PACKAGE BODY Object_Info IS
GENERIC
WITH FUNCTION Is_Desired (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Desired_Objects_From
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean) RETURN Directory_Tools.Object.Iterator;
FUNCTION Desired_Objects_From
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean)
RETURN Directory_Tools.Object.Iterator IS
--
All_Objects : Directory_Tools.Object.Iterator :=
Object_Info.Any.All_Objects_In (This_Object, Recursive);
--
Desired_Objects : Directory_Tools.Object.Iterator :=
Directory_Tools.Object.Create;
--
Dummy : Boolean;
--
BEGIN
Directory_Tools.Object.Reset (All_Objects);
WHILE (NOT Directory_Tools.Object.Done (All_Objects)) LOOP
IF (Is_Desired (Directory_Tools.Object.Value (All_Objects))) THEN
Directory_Tools.Object.Add
(Desired_Objects,
Directory_Tools.Object.Value (All_Objects), Dummy);
END IF;
Directory_Tools.Object.Next (All_Objects);
END LOOP;
RETURN (Desired_Objects);
END Desired_Objects_From;
GENERIC
WITH FUNCTION Is_Correct_Kind
(This_Library : IN Directory_Tools.Object.Handle)
RETURN Boolean;
FUNCTION Is_Enclosed
(This_Object : IN Directory_Tools.Object.Handle) RETURN Boolean;
FUNCTION Is_Enclosed (This_Object : IN Directory_Tools.Object.Handle)
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 : Directory_Tools.Object.Handle;
--
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;
PACKAGE BODY Any IS
FUNCTION Number_Of_Objects_In
(This_Iterator : IN Directory_Tools.Object.Iterator)
RETURN Natural IS
--
The_Objects : Directory_Tools.Object.Iterator := This_Iterator;
--
Count : Natural := 0;
--
BEGIN
Directory_Tools.Object.Reset (The_Objects);
WHILE (NOT Directory_Tools.Object.Done (The_Objects)) LOOP
Count := Count + 1;
Directory_Tools.Object.Next (The_Objects);
END LOOP;
RETURN (Count);
END Number_Of_Objects_In;
FUNCTION Number_Of_Objects_Enclosed_By
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Natural IS
BEGIN
IF (Recursive) THEN
RETURN (Number_Of_Objects_In
(Directory_Tools.Naming.Resolution
(Directory_Tools.Naming.Full_Name (This_Object) &
".@??")));
ELSE
RETURN (Number_Of_Objects_In
(Directory_Tools.Naming.Resolution
(Directory_Tools.Naming.Full_Name (This_Object) &
".@")));
END IF;
END Number_Of_Objects_Enclosed_By;
FUNCTION Classes_Equal
(This_Object : IN Directory_Tools.Object.Handle;
This_Class : IN Directory_Tools.Object.Class_Enumeration)
RETURN Boolean IS
BEGIN
RETURN (Directory_Tools.Object.Equal
(Directory_Tools.Object.Class (This_Object), This_Class));
END Classes_Equal;
FUNCTION Subclasses_Equal
(This_Object : IN Directory_Tools.Object.Handle;
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_Good (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
BEGIN
RETURN (NOT Directory_Tools.Object.Is_Bad (This_Object));
END Is_Good;
FUNCTION Is_Bad (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
BEGIN
RETURN (Directory_Tools.Object.Is_Bad (This_Object));
END Is_Bad;
FUNCTION Is_Library (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
BEGIN
RETURN (Directory_Tools.Library_Object.Is_Library (This_Object));
END Is_Library;
FUNCTION Is_Directory (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
BEGIN
RETURN (Directory_Tools.Library_Object.Is_Directory (This_Object));
END Is_Directory;
FUNCTION Is_World (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
BEGIN
RETURN (Directory_Tools.Library_Object.Is_World (This_Object));
END Is_World;
FUNCTION Is_Simple_World (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
BEGIN
RETURN ((Is_World (This_Object)) AND
(NOT Is_Subsystem (This_Object)) AND
(NOT Is_View (This_Object)));
END Is_Simple_World;
FUNCTION Is_Subsystem (This_Object : IN Directory_Tools.Object.Handle)
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_View (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
BEGIN
RETURN ((Subclasses_Equal (This_Object,
Object_Subclass.Spec_View_Subclass) OR
Subclasses_Equal (This_Object,
Object_Subclass.Load_View_Subclass) OR
Subclasses_Equal (This_Object,
Object_Subclass.Combined_View_Subclass)));
END Is_View;
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;
FUNCTION Is_Regular_Load_View
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
BEGIN
RETURN ((Subclasses_Equal (This_Object,
Object_Subclass.Load_View_Subclass)) AND
(NOT Is_Coded_Load_View (This_Object)));
END Is_Regular_Load_View;
FUNCTION Is_Coded_Load_View
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
--
-- Since there is no Code_View subclass, we need
-- to test for the presence or absence of a code
-- database. This kludge will hopefully go away
-- soon.
--
BEGIN
RETURN (Object_Info.Any.Is_Good
(Directory_Tools.Naming.Resolution
(Directory_Tools.Naming.Full_Name (This_Object) &
".CODE_DATABASE")));
END Is_Coded_Load_View;
FUNCTION Is_Combined_View
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
BEGIN
RETURN (Subclasses_Equal (This_Object,
Object_Subclass.Combined_View_Subclass));
END Is_Combined_View;
FUNCTION Is_Simple_Object
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
BEGIN
RETURN ((Is_Good (This_Object)) AND
(NOT Is_Library (This_Object)));
END Is_Simple_Object;
FUNCTION Is_Ada_Unit (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
BEGIN
RETURN (Classes_Equal (This_Object,
Directory_Tools.Object.Ada_Class));
END Is_Ada_Unit;
FUNCTION Is_File (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
BEGIN
RETURN (Classes_Equal (This_Object,
Directory_Tools.Object.File_Class));
END Is_File;
FUNCTION Is_Misc_Simple_Object
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
BEGIN
RETURN ((Is_Simple_Object (This_Object)) AND
(NOT Is_Ada_Unit (This_Object)) AND
(NOT Is_File (This_Object)));
END Is_Misc_Simple_Object;
FUNCTION Is_Frozen (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
BEGIN
RETURN (Directory_Tools.Any_Object.Is_Frozen (This_Object));
END Is_Frozen;
FUNCTION Contains_Libraries
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Number_Of_Objects_In
(Libraries_In (This_Object, Recursive)) > 0);
END Contains_Libraries;
FUNCTION Contains_Directories
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Number_Of_Objects_In
(Directories_In (This_Object, Recursive)) > 0);
END Contains_Directories;
FUNCTION Contains_Worlds
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Number_Of_Objects_In
(Worlds_In (This_Object, Recursive)) > 0);
END Contains_Worlds;
FUNCTION Contains_Simple_Worlds
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Number_Of_Objects_In
(Simple_Worlds_In (This_Object, Recursive)) > 0);
END Contains_Simple_Worlds;
FUNCTION Contains_Subsystems
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Number_Of_Objects_In
(Subsystems_In (This_Object, Recursive)) > 0);
END Contains_Subsystems;
FUNCTION Contains_Views
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Number_Of_Objects_In
(Views_In (This_Object, Recursive)) > 0);
END Contains_Views;
FUNCTION Contains_Spec_Views
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Number_Of_Objects_In
(Spec_Views_In (This_Object, Recursive)) > 0);
END Contains_Spec_Views;
FUNCTION Contains_Load_Views
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Number_Of_Objects_In
(Load_Views_In (This_Object, Recursive)) > 0);
END Contains_Load_Views;
FUNCTION Contains_Regular_Load_Views
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Number_Of_Objects_In
(Regular_Load_Views_In (This_Object, Recursive)) > 0);
END Contains_Regular_Load_Views;
FUNCTION Contains_Coded_Load_Views
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Number_Of_Objects_In
(Coded_Load_Views_In (This_Object, Recursive)) > 0);
END Contains_Coded_Load_Views;
FUNCTION Contains_Combined_Views
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Number_Of_Objects_In
(Combined_Views_In (This_Object, Recursive)) > 0);
END Contains_Combined_Views;
FUNCTION Contains_Simple_Objects
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Number_Of_Objects_In
(Simple_Objects_In (This_Object, Recursive)) > 0);
END Contains_Simple_Objects;
FUNCTION Contains_Ada_Units
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Number_Of_Objects_In
(Ada_Units_In (This_Object, Recursive)) > 0);
END Contains_Ada_Units;
FUNCTION Contains_Files
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Number_Of_Objects_In
(Files_In (This_Object, Recursive)) > 0);
END Contains_Files;
FUNCTION Contains_Misc_Simple_Objects
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Number_Of_Objects_In
(Misc_Simple_Objects_In (This_Object, Recursive)) > 0);
END Contains_Misc_Simple_Objects;
FUNCTION Contains_Frozen_Objects
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Number_Of_Objects_In
(Frozen_Objects_In (This_Object, Recursive)) > 0);
END Contains_Frozen_Objects;
FUNCTION Is_Enclosed_By_Subsystem IS NEW Is_Enclosed (Is_Subsystem);
FUNCTION Is_Contained_By_Subsystem
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
BEGIN
RETURN (Is_Enclosed_By_Subsystem (This_Object));
END Is_Contained_By_Subsystem;
FUNCTION Is_Enclosed_By_View IS NEW Is_Enclosed (Is_View);
FUNCTION Is_Contained_By_View
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
BEGIN
RETURN (Is_Enclosed_By_View (This_Object));
END Is_Contained_By_View;
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;
FUNCTION Is_Contained_By_Units_Directory_Of_View
(This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
--
Current_Library : Directory_Tools.Object.Handle := This_Object;
--
Result : Boolean := False;
--
BEGIN
IF (Is_Contained_By_View (This_Object)) THEN
LOOP
Current_Library := Directory_Tools.Traversal.Enclosing_Library
(Current_Library);
IF (Is_View (Current_Library)) THEN
-- Found the enclosing view. Now look for the object
-- in the units directory of the enclosing view.
IF (Directory_Tools.Object.Has
(Directory_Tools.Naming.Resolution
(Directory_Tools.Naming.Full_Name
(Current_Library) & ".UNITS.@??"),
This_Object)) THEN
Result := True;
ELSE
Result := False;
END IF;
EXIT;
END IF;
END LOOP;
END IF;
RETURN (Result);
END Is_Contained_By_Units_Directory_Of_View;
FUNCTION All_Objects_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
IF (Recursive) THEN
RETURN (Directory_Tools.Naming.Resolution
(Directory_Tools.Naming.Full_Name (This_Object) &
".@??"));
ELSE
RETURN (Directory_Tools.Naming.Resolution
(Directory_Tools.Naming.Full_Name (This_Object) &
".@"));
END IF;
END All_Objects_In;
FUNCTION Libraries IS NEW Desired_Objects_From (Is_Library);
FUNCTION Libraries_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Libraries (This_Object, Recursive));
END Libraries_In;
FUNCTION Directories IS NEW Desired_Objects_From (Is_Directory);
FUNCTION Directories_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Directories (This_Object, Recursive));
END Directories_In;
FUNCTION Worlds IS NEW Desired_Objects_From (Is_World);
FUNCTION Worlds_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Worlds (This_Object, Recursive));
END Worlds_In;
FUNCTION Simple_Worlds IS NEW Desired_Objects_From (Is_Simple_World);
FUNCTION Simple_Worlds_In (This_Object : IN
Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Simple_Worlds (This_Object, Recursive));
END Simple_Worlds_In;
FUNCTION Subsystems IS NEW Desired_Objects_From (Is_Subsystem);
FUNCTION Subsystems_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Subsystems (This_Object, Recursive));
END Subsystems_In;
FUNCTION Views IS NEW Desired_Objects_From (Is_View);
FUNCTION Views_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Views (This_Object, Recursive));
END Views_In;
FUNCTION Spec_Views IS NEW Desired_Objects_From (Is_Spec_View);
FUNCTION Spec_Views_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Spec_Views (This_Object, Recursive));
END Spec_Views_In;
FUNCTION Load_Views IS NEW Desired_Objects_From (Is_Load_View);
FUNCTION Load_Views_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Load_Views (This_Object, Recursive));
END Load_Views_In;
FUNCTION Regular_Load_Views IS
NEW Desired_Objects_From (Is_Regular_Load_View);
FUNCTION Regular_Load_Views_In
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Regular_Load_Views (This_Object, Recursive));
END Regular_Load_Views_In;
FUNCTION Coded_Load_Views IS
NEW Desired_Objects_From (Is_Coded_Load_View);
FUNCTION Coded_Load_Views_In (This_Object : IN
Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Coded_Load_Views (This_Object, Recursive));
END Coded_Load_Views_In;
FUNCTION Combined_Views IS NEW Desired_Objects_From (Is_Combined_View);
FUNCTION Combined_Views_In (This_Object : IN
Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Combined_Views (This_Object, Recursive));
END Combined_Views_In;
FUNCTION Simple_Objects IS NEW Desired_Objects_From (Is_Simple_Object);
FUNCTION Simple_Objects_In (This_Object : IN
Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Simple_Objects (This_Object, Recursive));
END Simple_Objects_In;
FUNCTION Ada_Units IS NEW Desired_Objects_From (Is_Ada_Unit);
FUNCTION Ada_Units_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Ada_Units (This_Object, Recursive));
END Ada_Units_In;
FUNCTION Files IS NEW Desired_Objects_From (Is_File);
FUNCTION Files_In (This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Files (This_Object, Recursive));
END Files_In;
FUNCTION Misc_Simple_Objects IS
NEW Desired_Objects_From (Is_Misc_Simple_Object);
FUNCTION Misc_Simple_Objects_In
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Misc_Simple_Objects (This_Object, Recursive));
END Misc_Simple_Objects_In;
FUNCTION Frozen_Objects IS NEW Desired_Objects_From (Is_Frozen);
FUNCTION Frozen_Objects_In (This_Object : IN
Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Frozen_Objects (This_Object, Recursive));
END Frozen_Objects_In;
END Any;
PACKAGE BODY Cmvc IS
FUNCTION Models_Equal
(This_View : IN Directory_Tools.Object.Handle;
This_Model : IN String := "!MODEL.R1000") RETURN Boolean IS
--
-- By a series of transformations, we convert the Directory_Tools.
-- Object.Handle for the view into an Object_Set.Iterator. Then we
-- iterate over the contents of the set, comparing the name of each
-- object in the set to the name of the model world until a match is
-- found or the iterator is done.
--
FUNCTION "=" (This_Error_Status : IN Directory.Error_Status;
That_Error_Status : IN Directory.Error_Status)
RETURN Boolean RENAMES Directory."=";
--
FUNCTION "=" (This_Error_Status : IN Directory.Naming.Name_Status;
That_Error_Status : IN Directory.Naming.Name_Status)
RETURN Boolean RENAMES Directory.Naming."=";
--
Model_World : Directory_Tools.Object.Handle :=
Directory_Tools.Naming.Resolution (This_Model);
--
Model_Name : CONSTANT String :=
String_Utilities.Upper_Case
(Directory_Tools.Naming.Full_Name (Model_World));
--
Object_Set_Name : CONSTANT String :=
Directory_Tools.Naming.Full_Name (This_View) & ".STATE.MODEL";
--
Object_Set_Object : Directory.Object;
--
The_Object_Set : Object_Set.Set;
--
Object_Iterator : Object_Set.Iterator;
--
Error_Status : Directory.Error_Status;
Name_Status : Directory.Naming.Name_Status;
--
Result : Boolean := False;
--
BEGIN
IF ((Object_Info.Any.Is_Good (This_View)) AND
(Object_Info.Any.Is_Good (Model_World))) THEN
Directory.Naming.Resolve (Object_Set_Name,
Object_Set_Object, Name_Status);
IF (Name_Status = Directory.Naming.Successful) THEN
Object_Set.Open (Object_Set_Object,
The_Object_Set, Error_Status);
IF (Error_Status = Directory.Successful) THEN
Object_Set.Init (Object_Iterator, The_Object_Set);
WHILE (NOT Object_Set.Done (Object_Iterator)) LOOP
DECLARE
Object : Directory.Object :=
Object_Set.Value (Object_Iterator);
Object_Name : CONSTANT String :=
String_Utilities.Upper_Case
(Directory.Naming.Get_Full_Name (Object));
BEGIN
IF (Object_Name = Model_Name) THEN
-- Models are the same.
Result := True;
EXIT;
END IF;
END;
Object_Set.Next (Object_Iterator);
END LOOP;
END IF;
END IF;
END IF;
Object_Set.Close (The_Set => The_Object_Set, Status => Error_Status);
RETURN (Result);
EXCEPTION
WHEN OTHERS =>
RETURN (False);
END Models_Equal;
FUNCTION Is_Controlled (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
--
FUNCTION "=" (This_Error_Status : IN Directory.Error_Status;
That_Error_Status : IN Directory.Error_Status)
RETURN Boolean RENAMES Directory."=";
--
The_Object : Directory.Object;
The_Status : Directory.Error_Status;
--
Object_Is_Controlled : Boolean := False;
--
BEGIN
Directory_Tools.Object.Low_Level.Get_Object
(This_Object, The_Object, The_Status);
Directory.Object_Operations.Is_Controlled
(The_Object, Object_Is_Controlled, The_Status);
RETURN ((The_Status = Directory.Successful) AND
(Object_Is_Controlled));
END Is_Controlled;
FUNCTION Is_Checked_Out (This_Object : IN Directory_Tools.Object.Handle)
RETURN Boolean IS
--
FUNCTION "=" (This_Error_Status : IN Directory.Error_Status;
That_Error_Status : IN Directory.Error_Status)
RETURN Boolean RENAMES Directory."=";
--
The_Object : Directory.Object;
The_Status : Directory.Error_Status;
--
Object_Is_Checked_In : Boolean;
--
BEGIN
Directory_Tools.Object.Low_Level.Get_Object
(This_Object, The_Object, The_Status);
Directory.Object_Operations.Is_Slushy
(The_Object, Object_Is_Checked_In, The_Status);
RETURN ((The_Status = Directory.Successful) AND
(NOT Object_Info.Any.Is_Library (This_Object)) AND
(Is_Controlled (This_Object)) AND
(NOT Object_Is_Checked_In));
END Is_Checked_Out;
FUNCTION Contains_Controlled_Objects
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Object_Info.Any.Number_Of_Objects_In
(Controlled_Objects_In (This_Object, Recursive)) > 0);
END Contains_Controlled_Objects;
FUNCTION Contains_Checked_Out_Objects
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True) RETURN Boolean IS
BEGIN
RETURN (Object_Info.Any.Number_Of_Objects_In
(Checked_Out_Objects_In (This_Object, Recursive)) > 0);
END Contains_Checked_Out_Objects;
FUNCTION Controlled_Objects IS NEW Desired_Objects_From (Is_Controlled);
FUNCTION Controlled_Objects_In
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Controlled_Objects (This_Object, Recursive));
END Controlled_Objects_In;
FUNCTION Checked_Out_Objects IS
NEW Desired_Objects_From (Is_Checked_Out);
FUNCTION Checked_Out_Objects_In
(This_Object : IN Directory_Tools.Object.Handle;
Recursive : IN Boolean := True)
RETURN Directory_Tools.Object.Iterator IS
BEGIN
RETURN (Checked_Out_Objects (This_Object, Recursive));
END Checked_Out_Objects_In;
END Cmvc;
END Object_Info;WITH Activity;
WITH Directory_Tools;
PACKAGE Object_Sets IS
-- This package provides a set abstraction built on top of the "Object.
-- Handle" and "Object.Iterator" abstractions of the "Directory_Tools"
-- package. Standard set operations such as union and intersection are
-- provided. In addition, operations are provided to create sets based
-- on relationships between compilation units.
--
-- Since the underlying representation of an object set is the same as
-- an object iterator, operations from the "Directory_Tools" package may
-- be freely applied to object sets, and vice versa.
--
-- This package has a renaming package "Object_Sets_Renames" associated
-- with it which allows the algebraic set operations defined in this
-- package to be written as infix operators.
--
-- Most operations in this package need to read more than one object
-- during execution. No synchronization is used by these operations: they
-- process only one object in a set at a time. This allows other users
-- to access objects in a set while the set is being processed without a
-- lock error occurring. There is the possibility, however, that another
-- user's access will partially invalidate the results of an operation,
-- and this needs to be taken into account.
SUBTYPE Object IS Directory_Tools.Object.Handle;
SUBTYPE Object_Set IS Directory_Tools.Object.Iterator;
FUNCTION Empty_Set RETURN Object_Set;
-- Returns a new set which contains no objects.
FUNCTION Is_Empty (This_Set : IN Object_Set) RETURN Boolean;
FUNCTION Number_In (This_Set : IN Object_Set) RETURN Natural;
FUNCTION Are_Equal (This_Set : IN Object_Set; That_Set : IN Object_Set)
RETURN Boolean;
-- Returns True if the sets contain exactly the same objects.
FUNCTION Copy_Of (This_Set : IN Object_Set) RETURN Object_Set;
FUNCTION Is_Member (This_Set : IN Object_Set; This_Object : IN Object)
RETURN Boolean;
PROCEDURE Add (This_Object : IN Object; This_Set : IN OUT Object_Set);
-- Adds the object to the set. Does nothing if the object is already
-- in the set.
PROCEDURE Remove (This_Object : IN Object; This_Set : IN OUT Object_Set);
-- Removes the object from the set. Does nothing if the object is not
-- in the set.
GENERIC
WITH FUNCTION "<" (This_Object : IN Object; That_Object : IN Object)
RETURN Boolean;
PROCEDURE Sort (This_Set : IN OUT Object_Set);
-- Sorts the objects in the specified set in accordance with the supplied
-- "<" function.
GENERIC
WITH FUNCTION Dont_Want (This_Object : IN Object) RETURN Boolean;
PROCEDURE Filter (This_Set : IN OUT Object_Set);
-- Removes objects from the specified set in accordance with the supplied
-- function "Dont_Want".
GENERIC
WITH PROCEDURE Process (This_Object : IN OUT Object);
PROCEDURE Process_Objects (This_Set : IN OUT Object_Set);
-- Applies the supplied processing procedure to all objects in the
-- specified set.
GENERIC
TYPE Process_State IS PRIVATE;
WITH PROCEDURE Initialize (This_State : IN OUT Process_State);
WITH PROCEDURE Process (This_Object : IN OUT Object;
This_State : IN OUT Process_State);
WITH PROCEDURE Finalize (This_State : IN OUT Process_State);
PROCEDURE Process_Objects_With_State (This_Set : IN OUT Object_Set;
This_State : IN OUT Process_State);
-- Applies the supplied processing procedure to all objects in the
-- specified set while preserving state information in a state variable
-- controlled by the client.
-- ALGEBRAIC OPERATIONS:
FUNCTION Union (This_Set : IN Object_Set; That_Set : IN Object_Set)
RETURN Object_Set;
-- Returns a new set which is the union of the two sets.
FUNCTION Intersection (This_Set : IN Object_Set; That_Set : IN Object_Set)
RETURN Object_Set;
-- Returns a new set which is the intersection of the two sets.
FUNCTION Exclusive_Or (This_Set : IN Object_Set; That_Set : IN Object_Set)
RETURN Object_Set;
-- Returns a new set which is the exclusive-or of the two sets.
FUNCTION Subtraction (This_Set : IN Object_Set; Except_For : IN Object_Set)
RETURN Object_Set;
-- Returns a new set which contains all objects in the first set
-- except for those which are also in the second set.
FUNCTION Subset (This_Set : IN Object_Set; Contains : IN Object_Set)
RETURN Boolean;
-- Returns True if the second set is a subset of the first set.
FUNCTION Proper_Subset (This_Set : IN Object_Set; Contains : IN Object_Set)
RETURN Boolean;
-- Returns True if the second set is a proper subset of the first set.
-- CLOSURE OPERATIONS:
-- The operations in this section create object sets based on the
-- dependency relationships between Ada units. There are several
-- parameters common to these operations:
--
-- * Specs_Only:
--
-- When this parameter is True, only Ada specs will be included.
--
-- * Transitive:
--
-- When this parameter is True, an object set will be generated
-- using transitive closure (if 'A' depends on 'B', and 'B'
-- depends on 'C', then 'A' depends on 'C' transitively).
--
-- * Include_Universe_Mirrors:
--
-- When this parameter is True, Ada specs which are an integral
-- part of the Rational Environment will be included.
--
-- * Code_Share_Generics:
--
-- When this parameter is True, generic instantiations will be
-- analyzed using a code-sharing model (as on the R1000).
--
-- When this parameter is False, generic instantiations will be
-- analyzed using a macro in-line expansion model (as on a VAX).
--
-- * This_Activity:
--
-- This parameter allows the client to specify which activity should
-- be used when subsystems are involved. In the default case, the
-- activity is empty and dependencies will not cross view boundaries.
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;
-- Returns a set containing every object which depends on the specified
-- unit. If the unit is a spec in a load view, the dependencies on the
-- corresponding spec in the spec view will be added to the closure.
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;
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;
-- Returns a set containing every object which is depended upon by the
-- specified unit. If the object depends upon a spec in a spec view,
-- the corresponding spec in the load view will be added to the closure.
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;
FUNCTION Withed_Objects (Unit : IN Object) RETURN Object_Set;
-- Returns a set containing the objects in the WITH clause(s)
-- of the specified unit.
FUNCTION Family (Unit : IN Object;
This_Activity : IN Activity.Activity_Name := Activity.Nil)
RETURN Object_Set;
-- Returns a set containing the objects in the "family" of the specified
-- unit. A family is defined as follows:
--
-- For a subunit: the subunit itself, and the transitive
-- closure of all subunits of the subunit.
--
-- For a body: the body itself, all subunits of the body,
-- and the families of those subunits.
--
-- For an ordinary spec: the spec itself, the body associated
-- with the spec, and the family of the body.
--
-- For a spec in a spec view: the family of the corresponding
-- spec in the load view specified in the activity.
END Object_Sets;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;WITH Object_Sets;
PACKAGE Object_Sets_Renames IS
SUBTYPE Object IS Object_Sets.Object;
SUBTYPE Object_Set IS Object_Sets.Object_Set;
FUNCTION "+" (This_Set : IN Object_Sets.Object_Set;
That_Set : IN Object_Sets.Object_Set)
RETURN Object_Sets.Object_Set RENAMES Object_Sets.Union;
FUNCTION "*" (This_Set : IN Object_Sets.Object_Set;
That_Set : IN Object_Sets.Object_Set)
RETURN Object_Sets.Object_Set RENAMES Object_Sets.Intersection;
FUNCTION "XOR" (This_Set : IN Object_Sets.Object_Set;
That_Set : IN Object_Sets.Object_Set)
RETURN Object_Sets.Object_Set
RENAMES Object_Sets.Exclusive_Or;
FUNCTION "-" (This_Set : IN Object_Sets.Object_Set;
Except_For : IN Object_Sets.Object_Set)
RETURN Object_Sets.Object_Set RENAMES Object_Sets.Subtraction;
FUNCTION ">=" (This_Set : IN Object_Sets.Object_Set;
Contains : IN Object_Sets.Object_Set) RETURN Boolean
RENAMES Object_Sets.Subset;
FUNCTION ">" (This_Set : IN Object_Sets.Object_Set;
Contains : IN Object_Sets.Object_Set) RETURN Boolean
RENAMES Object_Sets.Proper_Subset;
END Object_Sets_Renames;WITH Messages;
WITH Mailboxes;
WITH Destinations;
PACKAGE Command_Utilities IS
-- This package defines some utilities for use by the higher-level
-- command interpreter for the mail program.
TYPE Command_Kind IS (Headers, Read, Send, Delete, Quit, Unknown);
-- Defines the kind of commands the mail system implements. Read and Delete
-- take a single sequence number as an argument.
TYPE Command IS
RECORD
Kind : Command_Kind;
Message : Mailboxes.Sequence_Number := 0;
-- 0 indicates the command did not have a sequence number
END RECORD;
-- Defines the result of parsing a command line string.
FUNCTION Get_Command RETURN Command;
-- Reads a line of input from the user, parses it, and returns the command
-- that was entered.
FUNCTION Get_Message RETURN Messages.Message;
-- Prompts the user to input the values for the fields in a message to be
-- sent and returns the message entered.
PROCEDURE Display_Message (Message : Messages.Message);
-- Displays the indicated message to the user.
PROCEDURE Display_Headers (Mailbox : Mailboxes.Mailbox);
-- Displays the headers for the indicated mailbox to the user.
PROCEDURE Notify_Of_Receipt (Sending_User : Destinations.User;
Receiving_User : Destinations.User);
-- Sends a mail receipt notification to the Receiving_User indicating the
-- Sending_Users's name as the sender.
END Command_Utilities;WITH Messages;
WITH Mailboxes;
WITH Destinations;
WITH Io;
WITH Lines;
WITH Message;
WITH Time_Utilities;
WITH String_Utilities;
WITH Symbolic_Display;
PACKAGE BODY Command_Utilities IS
PACKAGE Su RENAMES String_Utilities;
PACKAGE Tu RENAMES Time_Utilities;
Unknown_Command : CONSTANT Command := (Unknown, 0);
FUNCTION Get_Natural_Argument
(Kind : Command_Kind; Command : String) RETURN Natural;
PROCEDURE New_Line;
PROCEDURE Display IS NEW Symbolic_Display (Io.Put, New_Line);
PROCEDURE New_Line IS
BEGIN
Io.New_Line;
END New_Line;
FUNCTION Get_Natural_Argument
(Kind : Command_Kind; Command : String) RETURN Natural IS
Start_Of_Argument : Natural := Su.Reverse_Locate (" ", Command);
Number : Natural;
Was_A_Number : Boolean;
BEGIN
Su.String_To_Number (Command (Start_Of_Argument .. Command'Last),
Number, Was_A_Number);
IF NOT Was_A_Number THEN
RAISE Constraint_Error;
END IF;
RETURN Number;
END Get_Natural_Argument;
FUNCTION Get_Command RETURN Command IS
-- Syntax: <command name> [" " <natural number>]
BEGIN
Io.Put ("MM> ");
DECLARE
Command : CONSTANT String := Su.Strip (Io.Get_Line);
BEGIN
FOR I IN Command_Kind'First .. Command_Kind'Last LOOP
BEGIN
IF Su.Equal (Command_Kind'Image (I),
Command (Command'First ..
Command'First +
Command_Kind'Image (I)'Length - 1),
Ignore_Case => True) THEN
CASE I IS
WHEN Headers | Send | Quit | Unknown =>
RETURN (I, 0);
WHEN Read | Delete =>
RETURN (I, Get_Natural_Argument (I, Command));
END CASE;
END IF;
EXCEPTION
WHEN Constraint_Error =>
NULL;
END;
END LOOP;
RETURN Unknown_Command;
END;
EXCEPTION
WHEN Constraint_Error =>
RETURN Unknown_Command;
END Get_Command;
FUNCTION Get_Message RETURN Messages.Message IS
Temp : Messages.Message := Messages.Make;
Text : Lines.Lines_Type := Lines.Make;
BEGIN
Io.Put ("To: ");
Messages.Set_To (Destinations.Lookup (Io.Get_Line), Temp);
Messages.Set_Date (Tu.Get_Time, Temp);
Io.Put ("Subject: ");
Messages.Set_Subject (Io.Get_Line, Temp);
Io.Put_Line ("Text: ");
DECLARE
Input_File : Io.File_Type := Io.Current_Input;
BEGIN
LOOP
Lines.Add (Io.Get_Line, Text);
END LOOP;
EXCEPTION
WHEN Io.End_Error =>
Messages.Set_Text (Text, Temp);
Io.Reset (Input_File);
Io.New_Line;
RETURN Temp;
END;
END Get_Message;
PROCEDURE Display_Message (Message : Messages.Message) IS
BEGIN
Display (Message);
END Display_Message;
PROCEDURE Display_Headers (Mailbox : Mailboxes.Mailbox) IS
BEGIN
FOR I IN 1 .. Mailboxes.Last_Message (Mailbox) LOOP
Io.Put (Natural'Image (I) & " ");
IF Mailboxes.Get_Read_Flag (I, Mailbox) THEN
Io.Put ("R ");
END IF;
Io.Put (Destinations.Image (Messages.Get_From
(Mailboxes.Get_Message (I, Mailbox))));
Io.New_Line;
END LOOP;
END Display_Headers;
PROCEDURE Notify_Of_Receipt (Sending_User : Destinations.User;
Receiving_User : Destinations.User) IS
BEGIN
Message.Send (Destinations.Image (Receiving_User),
"message received from " &
Destinations.Image (Sending_User));
END Notify_Of_Receipt;
END Command_Utilities;WITH Unbounded;
PACKAGE Destinations IS
-- This package provides an abstract state machine for defining the set
-- of users known to the application, looking up users given their string
-- representations, and iterating over all of the currently defined
-- users.
TYPE User IS PRIVATE;
PROCEDURE Define (New_User : String);
FUNCTION Image (The_User : User) RETURN String;
FUNCTION Lookup (Name : String) RETURN User;
Undefined : EXCEPTION;
-- Raised by Lookup if the user name is not defined.
TYPE User_Iterator IS PRIVATE;
-- For iterating over all of the currently-defined users.
FUNCTION Initialize RETURN User_Iterator;
PROCEDURE Next (Iter : IN OUT User_Iterator);
FUNCTION Value (Iter : User_Iterator) RETURN User;
FUNCTION Is_Done (Iter : User_Iterator) RETURN Boolean;
PRIVATE
TYPE User IS NEW Unbounded.Variable_String;
TYPE User_Iterator IS NEW Boolean; -- substitute your own type here.
END Destinations;WITH System_Utilities;
WITH String_Utilities;
PACKAGE BODY Destinations IS
PROCEDURE Define (New_User : String) IS
BEGIN
[statement]
END Define;
FUNCTION Image (The_User : User) RETURN String IS
BEGIN
RETURN Unbounded.Image (Unbounded.Variable_String (The_User));
END Image;
FUNCTION Lookup (Name : String) RETURN User IS
BEGIN
IF String_Utilities.Equal
(Name, System_Utilities.User_Name, Ignore_Case => True) THEN
RETURN Value (System_Utilities.User_Name);
ELSE
RAISE Undefined;
END IF;
END Lookup;
FUNCTION Initialize RETURN User_Iterator IS
BEGIN
[statement]
END Initialize;
PROCEDURE Next (Iter : IN OUT User_Iterator) IS
BEGIN
[statement]
END Next;
FUNCTION Value (Iter : User_Iterator) RETURN User IS
BEGIN
[statement]
END Value;
FUNCTION Is_Done (Iter : User_Iterator) RETURN Boolean IS
BEGIN
[statement]
END Is_Done;
END Destinations;WITH Unbounded;
PACKAGE Lines IS
-- This is the abstraction defining and manipulating lines of text.
SUBTYPE Line IS String;
-- Defines a single line of text.
TYPE Lines_Type IS PRIVATE;
-- Defines an abstraction for an ordered set of lines of text.
FUNCTION Make RETURN Lines_Type;
-- Returns an empty set of lines.
PROCEDURE Add (New_Line : Line; To : IN OUT Lines_Type);
-- Adds a new line to the end of the indicated lines.
TYPE Line_Iterator IS PRIVATE;
-- For iterating over each line in a set of lines (in order).
FUNCTION Initialize (Lines : Lines_Type) RETURN Line_Iterator;
FUNCTION Value (Iterator : Line_Iterator) RETURN Line;
PROCEDURE Next (Iterator : IN OUT Line_Iterator);
FUNCTION Is_Done (Iterator : Line_Iterator) RETURN Boolean;
PRIVATE
TYPE Lines_Record;
TYPE Lines_Type IS ACCESS Lines_Record;
TYPE Lines_Record IS
RECORD
My_Line : Unbounded.Variable_String;
Next : Lines_Type;
END RECORD;
TYPE Line_Iterator IS NEW Lines_Type;
END Lines;WITH Unbounded;
PACKAGE BODY Lines IS
FUNCTION Make RETURN Lines_Type IS
BEGIN
RETURN NULL;
END Make;
PROCEDURE Add (New_Line : Line; To : IN OUT Lines_Type) IS
BEGIN
IF To = NULL THEN
To := NEW Lines_Record'(Unbounded.Value (New_Line), NULL);
ELSE
DECLARE
Temp : Lines_Type :=
NEW Lines_Record'(Unbounded.Value (New_Line), NULL);
Temp2 : Lines_Type := To;
BEGIN
WHILE Temp2.ALL.Next /= NULL LOOP
Temp2 := Temp2.ALL.Next;
END LOOP;
Temp2.ALL.Next := Temp;
END;
END IF;
END Add;
FUNCTION Initialize (Lines : Lines_Type) RETURN Line_Iterator IS
BEGIN
RETURN Line_Iterator (Lines);
END Initialize;
FUNCTION Value (Iterator : Line_Iterator) RETURN Line IS
BEGIN
RETURN Unbounded.Image (Iterator.ALL.My_Line);
END Value;
PROCEDURE Next (Iterator : IN OUT Line_Iterator) IS
BEGIN
Iterator := Line_Iterator (Iterator.ALL.Next);
END Next;
FUNCTION Is_Done (Iterator : Line_Iterator) RETURN Boolean IS
BEGIN
RETURN Iterator = NULL;
END Is_Done;
END Lines;WITH Messages;
WITH List_Generic;
PACKAGE Mailboxes IS
-- This package defines an abstraction for defining and manipulating
-- mailboxes that contain messages.
SUBTYPE Sequence_Number IS Natural;
-- A way to refer to a message in a mailbox by indicating its position.
TYPE Mailbox IS PRIVATE;
FUNCTION Make RETURN Mailbox;
-- Returns an empty mailbox.
PROCEDURE Add (Message : Messages.Message; The_Mailbox : IN OUT Mailbox);
-- Adds a message to the end of a mailbox. The "Read" flag for the new
-- message is set to False.
FUNCTION Last_Message (The_Mailbox : Mailbox) RETURN Sequence_Number;
-- Returns the index of the last message in the mailbox. 0 iff no messages.
FUNCTION Get_Message (Message : Sequence_Number; The_Mailbox : Mailbox)
RETURN Messages.Message;
-- Returns the indicated message from the mailbox.
FUNCTION Get_Read_Flag (Message : Sequence_Number; The_Mailbox : Mailbox)
RETURN Boolean;
-- Returns the value of the "Read" flag from the indicated message.
PROCEDURE Set_Read_Flag (Message : Sequence_Number;
New_Value : Boolean;
The_Mailbox : IN OUT Mailbox);
-- Sets the "Read" flag for the indicated message to the value supplied.
PROCEDURE Delete_Message (Message : Sequence_Number;
The_Mailbox : IN OUT Mailbox);
-- Deletes the indicated message from the mailbox.
Nonexistent_Sequence_Number : EXCEPTION;
-- Raised if the Sequence_Number supplied to any of the above operations
-- is > the number of messages in the mailbox.
PRIVATE
TYPE Mailbox_Entry IS
RECORD
Read_Flag : Boolean;
Message : Messages.Message;
END RECORD;
PACKAGE Mailbox_List IS NEW List_Generic (Mailbox_Entry);
TYPE Mailbox IS NEW Mailbox_List.List;
END Mailboxes;WITH Messages;
PACKAGE BODY Mailboxes IS
PROCEDURE Find_Message (Message : Sequence_Number;
The_Mailbox : IN OUT Mailbox);
FUNCTION Make RETURN Mailbox IS
BEGIN
RETURN Nil;
END Make;
PROCEDURE Add (Message : Messages.Message; The_Mailbox : IN OUT Mailbox) IS
New_Entry : CONSTANT Mailbox := Make ((False, Message), Nil);
Temp : Mailbox := The_Mailbox;
BEGIN
IF Is_Empty (Temp) THEN
The_Mailbox := New_Entry;
ELSE
WHILE NOT Is_Empty (Rest (Temp)) LOOP
Temp := Rest (Temp);
END LOOP;
Set_Rest (Temp, New_Entry);
END IF;
END Add;
FUNCTION Last_Message (The_Mailbox : Mailbox) RETURN Sequence_Number IS
BEGIN
RETURN Length (The_Mailbox);
END Last_Message;
PROCEDURE Find_Message (Message : Sequence_Number;
The_Mailbox : IN OUT Mailbox) IS
BEGIN
IF Message = 0 OR ELSE Length (The_Mailbox) < Message THEN
RAISE Nonexistent_Sequence_Number;
END IF;
FOR I IN 1 .. Message - 1 LOOP
The_Mailbox := Rest (The_Mailbox);
END LOOP;
END Find_Message;
FUNCTION Get_Message (Message : Sequence_Number; The_Mailbox : Mailbox)
RETURN Messages.Message IS
Temp : Mailbox := The_Mailbox;
BEGIN
Find_Message (Message, Temp);
RETURN First (Temp).Message;
END Get_Message;
FUNCTION Get_Read_Flag (Message : Sequence_Number; The_Mailbox : Mailbox)
RETURN Boolean IS
Temp : Mailbox := The_Mailbox;
BEGIN
Find_Message (Message, Temp);
RETURN First (Temp).Read_Flag;
END Get_Read_Flag;
PROCEDURE Set_Read_Flag (Message : Sequence_Number;
New_Value : Boolean;
The_Mailbox : IN OUT Mailbox) IS
Temp : Mailbox := The_Mailbox;
BEGIN
Find_Message (Message, Temp);
DECLARE
New_Entry : CONSTANT Mailbox_Entry :=
(New_Value, First (Temp).Message);
BEGIN
Set_First (Temp, New_Entry);
END;
END Set_Read_Flag;
PROCEDURE Delete_Message (Message : Sequence_Number;
The_Mailbox : IN OUT Mailbox) IS
Temp : Mailbox := The_Mailbox;
BEGIN
IF Message = 1 THEN
The_Mailbox := Rest (The_Mailbox);
ELSE
Find_Message (Message - 1, Temp);
Set_Rest (Temp, Rest (Rest (Temp)));
END IF;
END Delete_Message;
END Mailboxes;WITH Lines;
WITH Time_Utilities;
WITH Destinations;
WITH Unbounded;
PACKAGE Messages IS
-- This is the abstraction for representing messages
PACKAGE Tu RENAMES Time_Utilities;
SUBTYPE Destination IS Destinations.User;
TYPE Message IS PRIVATE;
-- Defines a message
FUNCTION Make RETURN Message;
-- Returns a new Message with default field values for
-- the To, From, Date, Subject, and Text fields.
PROCEDURE Set_To (To : Destination; The_Message : IN OUT Message);
PROCEDURE Set_From (From : Destination; The_Message : IN OUT Message);
PROCEDURE Set_Date (Date : Tu.Time; The_Message : IN OUT Message);
PROCEDURE Set_Subject (Subject : Lines.Line; The_Message : IN OUT Message);
PROCEDURE Set_Text (Text : Lines.Lines_Type; The_Message : IN OUT Message);
-- The above constructors set the various fields of messages.
FUNCTION Get_To (The_Message : Message) RETURN Destination;
FUNCTION Get_From (The_Message : Message) RETURN Destination;
FUNCTION Get_Date (The_Message : Message) RETURN Tu.Time;
FUNCTION Get_Subject (The_Message : Message) RETURN Lines.Line;
FUNCTION Get_Text (The_Message : Message) RETURN Lines.Lines_Type;
-- The above selectors return the various fields of messages.
PRIVATE
TYPE Message IS
RECORD
Message_To : Destinations.User;
Message_From : Destinations.User;
Message_Date : Tu.Time;
Message_Subject : Unbounded.Variable_String;
Message_Text : Lines.Lines_Type;
END RECORD;
END Messages;WITH Lines, Time_Utilities, Unbounded;
PACKAGE BODY Messages IS
FUNCTION Make RETURN Message IS
New_Message : Message;
BEGIN
RETURN New_Message;
END Make;
PROCEDURE Set_To (To : Destination; The_Message : IN OUT Message) IS
BEGIN
The_Message.Message_To := To;
END Set_To;
PROCEDURE Set_From (From : Destination; The_Message : IN OUT Message) IS
BEGIN
The_Message.Message_From := From;
END Set_From;
PROCEDURE Set_Date (Date : Tu.Time; The_Message : IN OUT Message) IS
BEGIN
The_Message.Message_Date := Date;
END Set_Date;
PROCEDURE Set_Subject (Subject : Lines.Line;
The_Message : IN OUT Message) IS
BEGIN
The_Message.Message_Subject := Unbounded.Value (Subject);
END Set_Subject;
PROCEDURE Set_Text (Text : Lines.Lines_Type;
The_Message : IN OUT Message) IS
BEGIN
The_Message.Message_Text := Text;
END Set_Text;
FUNCTION Get_To (The_Message : Message) RETURN Destination IS
BEGIN
RETURN The_Message.Message_To;
END Get_To;
FUNCTION Get_From (The_Message : Message) RETURN Destination IS
BEGIN
RETURN The_Message.Message_From;
END Get_From;
FUNCTION Get_Date (The_Message : Message) RETURN Tu.Time IS
BEGIN
RETURN The_Message.Message_Date;
END Get_Date;
FUNCTION Get_Subject (The_Message : Message) RETURN Lines.Line IS
BEGIN
RETURN Unbounded.Image (The_Message.Message_Subject);
END Get_Subject;
FUNCTION Get_Text (The_Message : Message) RETURN Lines.Lines_Type IS
BEGIN
RETURN The_Message.Message_Text;
END Get_Text;
END Messages;PROCEDURE Run_Mail (User_Name : String := "<Current_User>");
-- Starts a mail command simulator in a window for the indicated user.
-- By default the simulator will be created for the current user name.
--
-- The simulator prompts in an I/O window with the symbol: MM>
--
-- The commands avaiable at the prompt are (where "#" is a message number as
-- displayed by the HEADER command):
-- HEADERS - no argument required
-- READ # - to read the specified message
-- SEND - to "send" a message (into your own "mailbox")
-- - the text entry is terminated by entering [End of Input] or a
-- [<Numeric>.] (i.e. the "." on the numeric keypad)
-- DELETE # - to delete the specified message
-- QUIT - to exit the command interpreter
--
-- Unknown commands provide a command-list prompt
WITH Io;
WITH Messages;
WITH Mailboxes;
WITH Destinations;
WITH Command_Utilities;
WITH System_Utilities;
PROCEDURE Run_Mail (User_Name : String := "<Current_User>") IS
PACKAGE Cu RENAMES Command_Utilities;
Mailbox : Mailboxes.Mailbox := Mailboxes.Make;
Command : Cu.Command;
Message : Messages.Message;
Current_User : Destinations.User;
FUNCTION Get_User (Name : String) RETURN String;
FUNCTION Get_User (Name : String) RETURN String IS
BEGIN
IF Name = "<Current_User>" THEN
RETURN System_Utilities.User_Name;
ELSE
RETURN Name;
END IF;
END Get_User;
BEGIN
BEGIN
Current_User := Destinations.Lookup (Get_User (User_Name));
EXCEPTION
WHEN Destinations.Undefined =>
Io.Put_Line ("Sorry, can only run simulation for current user.");
RETURN;
END;
LOOP
Command := Cu.Get_Command;
CASE Command.Kind IS
WHEN Cu.Headers =>
Cu.Display_Headers (Mailbox);
WHEN Cu.Read =>
Cu.Display_Message (Mailboxes.Get_Message
(Command.Message, Mailbox));
Mailboxes.Set_Read_Flag (Command.Message, True, Mailbox);
WHEN Cu.Send =>
BEGIN
Message := Cu.Get_Message;
Messages.Set_From (Current_User, Message);
Mailboxes.Add (Message, Mailbox);
Cu.Notify_Of_Receipt (Current_User, Messages.Get_To (Message));
EXCEPTION
WHEN Destinations.Undefined =>
Io.Put_Line ("Sorry, undefined user name entered.");
END;
WHEN Cu.Delete =>
Mailboxes.Delete_Message (Command.Message, Mailbox);
WHEN Cu.Quit =>
EXIT;
WHEN Cu.Unknown =>
Io.Put_Line ("Unknown command entered. Please try again.");
Io.Put ("Legal commands are: ");
FOR I IN Cu.Headers .. Cu.Quit LOOP
Io.Put (Cu.Command_Kind'Image (I));
Io.Put (' ');
END LOOP;
Io.New_Line;
END CASE;
END LOOP;
END Run_Mail;WITH Messages;
GENERIC
WITH PROCEDURE Put (Text : String);
WITH PROCEDURE New_Line;
PROCEDURE Symbolic_Display (The_Message : Messages.Message);
-- This procedure will put out an image of the given message using the
-- Put and New_Line procedures provided.WITH Destinations;
WITH Messages;
WITH Lines;
WITH Time_Utilities;
WITH Unbounded;
PROCEDURE Symbolic_Display (The_Message : Messages.Message) IS
PACKAGE Tu RENAMES Time_Utilities;
Iter : Lines.Line_Iterator := Lines.Initialize
(Messages.Get_Text (The_Message));
BEGIN
Put ("To: " & Destinations.Image (Messages.Get_To (The_Message)));
New_Line;
Put ("From: " & Destinations.Image (Messages.Get_From (The_Message)));
New_Line;
Put ("Date: " & Tu.Image (Messages.Get_Date (The_Message)));
New_Line;
Put ("Subject: " & Messages.Get_Subject (The_Message));
New_Line;
Put ("Text:");
New_Line;
WHILE NOT Lines.Is_Done (Iter) LOOP
Put (Lines.Value (Iter));
New_Line;
Lines.Next (Iter);
END LOOP;
END Symbolic_Display;WITH Unbounded_String;
PACKAGE Unbounded IS NEW Unbounded_String;!USERS.PDM_MASTER.MAIL_SOLUTION.MAILBOX.REV1_0_SPEC
!USERS.PDM_MASTER.MAIL_SOLUTION.MAIL_UTILITIES.REV1_0_SPEC!USERS.PDM_MASTER.MAIL_SOLUTION.MAIL_MODELREV1c