|
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 - metrics - download
Length: 1028372 (0xfb114)
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«
└─⟦711653f67⟧
└─⟦this⟧
procedure Aedit (The_Activity : String := "<ACTIVITY>");
pragma Main;with Activity;
procedure Aedit (The_Activity : String := "<ACTIVITY>") is
begin
Activity.Edit (The_Activity);
end Aedit;procedure Alist (Pattern : String := "@'C(ADA)";
Descending : Boolean := False;
Response : String := "<PROFILE>";
Options : String := "");
pragma Main;with Library;
procedure Alist (Pattern : String := "@'C(ADA)";
Descending : Boolean := False;
Response : String := "<PROFILE>";
Options : String := "") is
begin
Library.Ada_List (Pattern,
Descending => Descending,
Response => Response,
Options => Options);
end Alist;procedure Cancel_Print_Request
(Printer : String := "<Default>"; Request_Id : Positive);
--
-- Removes the specified print request from the queue of the
-- specified printer.
--
-- The Printer parameter accepts any printer name that has been
-- defined in the printer-configuration files. By default, the
-- parameter specifies the printer that is associated with the
-- user who enters the command.
--
-- Print request numbers, can be obtained from the display
-- generated by the Display_Queue procedure in this directory.
pragma Main;with Io;
with Io_Exceptions;
with String_Utilities;
with System_Utilities;
with Queue;
with Remote;
procedure Cancel_Print_Request
(Printer : String := "<Default>"; Request_Id : Positive) is
package Strings renames String_Utilities;
Map_Filename : constant String := "!Machine.Queues.User_To_Printer_Map";
function Eq (A, B : String; Ignore_Case : Boolean := True) return Boolean
renames Strings.Equal;
function Get_Queue_Class return String is
F : Io.File_Type;
Next : Integer;
function Match (Pattern, Name : String) return Boolean is
begin
if Name'Length /= 0 and then Name (Name'First) = '*' then
return Eq (Pattern, Name);
elsif Eq (Pattern, "others") then
return True;
elsif Pattern = "@" then
return True;
else
return Eq (Pattern, Name);
end if;
end Match;
function Get_User_Printer (Printer : String) return String is
-- given the global printer parameter which is either <default> or
-- a printer name, return the string to search for in the user
-- to printer map file. If <default> this is the user name,
-- else it is the value of the parameter prefixed with an "*".
begin
if Eq (Printer, "<Default>") then
return System_Utilities.User_Name;
elsif Eq (Printer, "Others") then
return Printer;
else
return "*" & Printer;
end if;
end Get_User_Printer;
function Token (S : String) return String is
Start, Stop : Natural;
begin
if Next = -1 then
Next := S'First; -- tricky initialization
end if;
Start := Next;
-- skip leading blanks
while Start <= S'Last and then S (Start) = ' ' loop
Start := Start + 1;
end loop;
Next := Start;
while Next <= S'Last and then S (Next) /= ' ' loop
Next := Next + 1;
end loop;
if Start <= S'Last then
if Next > S'Last then
Stop := S'Last;
else -- S (Next) = ' '
Stop := Next - 1;
end if;
return S (Start .. Stop);
else
return "";
end if;
end Token;
begin
-- Find printer information in the user printer map
declare
User : constant String := Get_User_Printer (Printer);
begin
Io.Open (F, Io.In_File, Map_Filename);
while not Io.End_Of_File (F) loop
Next := -1;
declare
Line : constant String := Io.Get_Line (F);
User_Name : constant String := Token (Line);
Class_Name : constant String := Token (Line);
begin
if User_Name'Length < 2 or else
User_Name (User_Name'First .. User_Name'First + 1) /=
"--" then
if Match (User_Name, User) then
Io.Close (F);
return Class_Name;
end if;
end if;
end;
end loop;
-- Didn't find a match!
Io.Close (F);
-- Therefore return the passed value
return Printer;
end;
exception
when Io_Exceptions.Name_Error =>
-- map file does not exist!
return Printer;
end Get_Queue_Class;
function Is_Remote_Name (Name : String) return Boolean is
begin
return Name'Length >= 2 and then
Name (Name'First .. Name'First + 1) = "!!";
end Is_Remote_Name;
begin
declare
Printer_Class : constant String := Get_Queue_Class;
begin
if Is_Remote_Name (Printer_Class) then
declare
Machine_Start : Natural := Strings.Locate
("!!", Printer_Class, True) + 2;
Machine_End : Natural := Strings.Locate
(".", Printer_Class, True) - 1;
Machine_Name : constant String :=
Printer_Class (Machine_Start .. Machine_End);
begin
Remote.Run (Machine => Machine_Name,
Command => "Queue.Cancel(Request_Id =>" &
Positive'Image (Request_Id) & ");",
File_Context => "!Machine",
Run_Context => "!Machine",
Options => "",
Response => "<PROGRESS>");
end;
else
Queue.Cancel (Request_Id => Request_Id);
end if;
end;
end Cancel_Print_Request;procedure Code (Unit : String := "<IMAGE>";
Limit : String := "<WORLDS>";
Effort_Only : Boolean := False;
Response : String := "<PROFILE>");
pragma Main;with Compilation;
with File_Utilities;
with Io;
with Library;
with Log;
with System_Utilities;
procedure Code (Unit : String := "<IMAGE>";
Limit : String := "<WORLDS>";
Effort_Only : Boolean := False;
Response : String := "<PROFILE>") is
Log_Name : constant String := System_Utilities.User_Name & "_Code_Log";
procedure Echo_Line (S : String) is
begin
Io.Echo_Line (S);
exception
when others =>
null;
end Echo_Line;
begin
Library.Context ("$", Response => "");
Echo_Line ("Code log generated in " & Log_Name & '.');
Log.Set_Log (Log_Name);
Compilation.Make (Unit => Unit,
Limit => Limit,
Effort_Only => Effort_Only,
Goal => Compilation.Coded,
Response => Response);
Log.Reset_Log;
begin
if File_Utilities.Found ("++*", Log_Name, Ignore_Case => False) > 0 then
Echo_Line (System_Utilities.Job_Name &
" has generated errors in " & Log_Name);
end if;
exception
when others =>
Echo_Line ("Unable to check " & Log_Name & " for errors.");
end;
end Code;procedure Compare (File_1 : String := "<REGION>";
File_2 : String := "<IMAGE>";
Subobjects : Boolean := False;
Ignore_Case : Boolean := False;
Options : String := "");
pragma Main;with File_Utilities;
procedure Compare (File_1 : String := "<REGION>";
File_2 : String := "<IMAGE>";
Subobjects : Boolean := False;
Ignore_Case : Boolean := False;
Options : String := "") is
begin
File_Utilities.Compare (File_1, File_2, Subobjects, Ignore_Case, Options);
end Compare;procedure Ddef (Location : String := "<SELECTION>"; Stack_Frame : Integer := 0);
pragma Main;with Debug;
procedure Ddef (Location : String := "<SELECTION>";
Stack_Frame : Integer := 0) is
begin
Debug.Source (Location, Stack_Frame);
end Ddef;
pragma Main;procedure Def (Name : String := "<CURSOR>";
In_Place : Boolean := False;
Visible : Boolean := True);
pragma Main;with Common;
procedure Def (Name : String := "<CURSOR>";
In_Place : Boolean := False;
Visible : Boolean := True) is
begin
Common.Definition (Name, In_Place, Visible);
end Def;procedure Diff (File_1 : String := "<REGION>";
File_2 : String := "<IMAGE>";
Result : String := "";
Compressed_Output : Boolean := False;
Subobjects : Boolean := False);
pragma Main;with File_Utilities;
procedure Diff (File_1 : String := "<REGION>";
File_2 : String := "<IMAGE>";
Result : String := "";
Compressed_Output : Boolean := False;
Subobjects : Boolean := False) is
begin
File_Utilities.Difference (File_1, File_2, Result,
Compressed_Output, Subobjects);
end Diff;procedure Disk_Space;with Operator;
procedure Disk_Space is
begin
Operator.Disk_Space;
end Disk_Space;
pragma Main;procedure Display_Queue (Printer : String := "<Default>");
--
-- Displays the print requests currently queued on the specified
-- printer.
--
-- The display shows the identification number for each request.
--
-- The Printer parameter accepts any print name that has been
-- defined in the printer_configuration files. By default,
-- the parameter specifies the printer that is associated with
-- the user who enters the command.
pragma Main;with Io;
with Io_Exceptions;
with String_Utilities;
with System_Utilities;
with Queue;
procedure Display_Queue (Printer : String := "<Default>") is
package Strings renames String_Utilities;
Map_Filename : constant String := "!Machine.Queues.User_To_Printer_Map";
function Eq (A, B : String; Ignore_Case : Boolean := True) return Boolean
renames Strings.Equal;
function Get_Queue_Class return String is
F : Io.File_Type;
Next : Integer;
function Match (Pattern, Name : String) return Boolean is
begin
if Name'Length /= 0 and then Name (Name'First) = '*' then
return Eq (Pattern, Name);
elsif Eq (Pattern, "others") then
return True;
elsif Pattern = "@" then
return True;
else
return Eq (Pattern, Name);
end if;
end Match;
function Get_User_Printer (Printer : String) return String is
-- given the global printer parameter which is either <default> or
-- a printer name, return the string to search for in the user
-- to printer map file. If <default> this is the user name,
-- else it is the value of the parameter prefixed with an "*".
begin
if Eq (Printer, "<Default>") then
return System_Utilities.User_Name;
elsif Eq (Printer, "Others") then
return Printer;
else
return "*" & Printer;
end if;
end Get_User_Printer;
function Token (S : String) return String is
Start, Stop : Natural;
begin
if Next = -1 then
Next := S'First; -- tricky initialization
end if;
Start := Next;
-- skip leading blanks
while Start <= S'Last and then S (Start) = ' ' loop
Start := Start + 1;
end loop;
Next := Start;
while Next <= S'Last and then S (Next) /= ' ' loop
Next := Next + 1;
end loop;
if Start <= S'Last then
if Next > S'Last then
Stop := S'Last;
else -- S (Next) = ' '
Stop := Next - 1;
end if;
return S (Start .. Stop);
else
return "";
end if;
end Token;
begin
-- Find printer information in the user printer map
declare
User : constant String := Get_User_Printer (Printer);
begin
Io.Open (F, Io.In_File, Map_Filename);
while not Io.End_Of_File (F) loop
Next := -1;
declare
Line : constant String := Io.Get_Line (F);
User_Name : constant String := Token (Line);
Class_Name : constant String := Token (Line);
begin
if User_Name'Length < 2 or else
User_Name (User_Name'First .. User_Name'First + 1) /=
"--" then
if Match (User_Name, User) then
Io.Close (F);
return Class_Name;
end if;
end if;
end;
end loop;
-- Didn't find a match!
Io.Close (F);
-- Therefore return passed value
return Printer;
end;
exception
when Io_Exceptions.Name_Error =>
-- map file does not exist!
return Printer;
end Get_Queue_Class;
begin
Queue.Display (Get_Queue_Class);
end Display_Queue;with System_Backup;
procedure Do_Backup (Variety : System_Backup.Kind := System_Backup.Full;
Starting_At : String := "");
pragma Main;with Daemon;
with Io;
with Log;
with Message;
with Profile;
with Scheduler;
with System_Backup;
with Time_Utilities;
procedure Do_Backup (Variety : System_Backup.Kind := System_Backup.Full;
Starting_At : String := "") is
Delay_For : Duration;
Warning : Duration;
Start_Message : Boolean;
Finish_Message : Boolean;
Got_Snapshot_Info : Boolean := False;
Got_Scheduler_Info : Boolean := False;
Memory_Scheduling : Integer;
Memory_Scheduling_String : constant String := "Memory_Scheduling";
procedure Backup_Finishing (Was_Successful : Boolean) is
begin
if Got_Snapshot_Info then
-- Restore snapshot warning to previous setting
Got_Snapshot_Info := False;
Daemon.Snapshot_Warning_Message (Interval => Warning);
Daemon.Snapshot_Start_Message (Start_Message);
Daemon.Snapshot_Finish_Message (Finish_Message);
end if;
if Got_Scheduler_Info then
-- Restore scheduler settings
Got_Scheduler_Info := False;
Scheduler.Set (Memory_Scheduling_String, Memory_Scheduling);
end if;
end Backup_Finishing;
procedure Backup_Starting (Is_Full : Boolean) is
begin
-- Warn users that backup is starting
if Is_Full then
Message.Send_All ("Starting full system backup");
else
Message.Send_All ("Starting incremental system backup);");
end if;
-- Save current scheduler settings
Memory_Scheduling := Scheduler.Get (Memory_Scheduling_String);
Got_Scheduler_Info := True;
Scheduler.Set (Memory_Scheduling_String, 0); -- turn off scheduling
-- Save current snapshot settings and turn off snapshot warnings.
Daemon.Get_Snapshot_Settings (Warning, Start_Message, Finish_Message);
Got_Snapshot_Info := True;
Daemon.Snapshot_Warning_Message (Interval => 0.0);
Daemon.Snapshot_Start_Message;
end Backup_Starting;
procedure Backup is new System_Backup.Backup_Generic
(Backup_Starting, Backup_Finishing);
begin
if Starting_At'Length > 0 then
begin
Delay_For := Time_Utilities.Duration_Until
(Time_Utilities.Value (Starting_At));
exception
when others =>
Log.Put_Line ("Invalid starting time value given.",
Kind => Profile.Error_Msg);
return;
end;
end if;
-- Do the backup
Backup (Variety => Variety, Wait_Until => Starting_At);
-- Take snapshot to make full backups official; i.e. allow differentials
Daemon.Run ("Snapshot");
exception
when others =>
Io.Put_Line (Io.Current_Error,
"Backup failed with an unhandled exception.");
Backup_Finishing (False);
end Do_Backup;procedure Exp (Existing : String := "<cursor>");with Library;
procedure Exp (Existing : String := "<cursor>") is
begin
Library.Expunge (Existing => Existing,
Keep_Versions => 0,
Recursive => True,
Response => "<errors>");
end Exp;
pragma Main;procedure Find (Pattern : String := "";
File : String := "<IMAGE>";
Wildcards : Boolean := False;
Ignore_Case : Boolean := True;
Result : String := "");
pragma Main;with File_Utilities;
procedure Find (Pattern : String := "";
File : String := "<IMAGE>";
Wildcards : Boolean := False;
Ignore_Case : Boolean := True;
Result : String := "") is
begin
File_Utilities.Find (Pattern, File, Wildcards, Ignore_Case, Result);
end Find;procedure Full_Backup (Starting_At : String := "");
pragma Main;with Do_Backup;
with System_Backup;
procedure Full_Backup (Starting_At : String := "") is
begin
Do_Backup (Variety => System_Backup.Full, Starting_At => Starting_At);
end Full_Backup;procedure Help (Name : String := "Help_On_Help");
pragma Main;with What;
procedure Help (Name : String := "Help_On_Help") is
begin
What.Does (Name);
end Help;procedure Input (Name : String := "<CURSOR>");
pragma Main;with Io;
procedure Input (Name : String := "<CURSOR>") is
begin
Io.Set_Input (Name);
end Input;procedure Install (Unit : String := "<IMAGE>";
Limit : String := "<WORLDS>";
Effort_Only : Boolean := False;
Response : String := "<PROFILE>");
pragma Main;with Compilation;
with File_Utilities;
with Io;
with Library;
with Log;
with System_Utilities;
procedure Install (Unit : String := "<IMAGE>";
Limit : String := "<WORLDS>";
Effort_Only : Boolean := False;
Response : String := "<PROFILE>") is
Log_Name : constant String := System_Utilities.User_Name & "_Install_Log";
procedure Echo_Line (S : String) is
begin
Io.Echo_Line (S);
exception
when others =>
null;
end Echo_Line;
begin
Library.Context ("$", Response => "");
Echo_Line ("Install log generated in " & Log_Name & '.');
Log.Set_Log (Log_Name);
Compilation.Promote (Unit => Unit,
Limit => Limit,
Effort_Only => Effort_Only,
Response => Response);
Log.Reset_Log;
begin
if File_Utilities.Found ("++*", Log_Name, Ignore_Case => False) > 0 then
Echo_Line (System_Utilities.Job_Name &
" has generated errors in " & Log_Name);
end if;
exception
when others =>
Echo_Line ("Unable to check " & Log_Name & " for errors.");
end;
end Install;procedure Ledit (World : String := "<IMAGE>");
pragma Main;with Links;
procedure Ledit (World : String := "<IMAGE>") is
begin
Links.Edit (World);
end Ledit;procedure List (Pattern : String := "@";
Descending : Boolean := False;
Response : String := "<PROFILE>";
Options : String := "");
pragma Main;with Library;
procedure List (Pattern : String := "@";
Descending : Boolean := False;
Response : String := "<PROFILE>";
Options : String := "") is
F : Library.Fields := Library.Terse_Format;
begin
F (Library.Version) := True;
F (Library.Class) := True;
F (Library.Size) := True;
F (Library.Status) := True;
Library.List (Pattern, F,
Descending => Descending,
Response => Response,
Options => Options);
end List;procedure Need (Unit : String := "<IMAGE>";
Transitive : Boolean := False;
Response : String := "<PROFILE>");
pragma Main;with Compilation;
procedure Need (Unit : String := "<IMAGE>";
Transitive : Boolean := False;
Response : String := "<PROFILE>") is
begin
Compilation.Dependents (Unit, Transitive, Response);
end Need;procedure Output (Name : String := ">>FILE NAME<<");
pragma Main;with Io;
with Log;
procedure Output (Name : String := ">>FILE NAME<<") is
begin
Log.Set_Output (Name);
Io.Set_Error (Io.Current_Output);
end Output;procedure Primary_Backup (Starting_At : String := "");
pragma Main;with Do_Backup;
with System_Backup;
procedure Primary_Backup (Starting_At : String := "") is
begin
Do_Backup (Variety => System_Backup.Primary, Starting_At => Starting_At);
end Primary_Backup;procedure Print (Object_Or_Image : String := "<CURSOR>";
From_First_Page : Positive := 1;
To_Last_Page : Positive := 3000;
Display_As_Twoup : Boolean := True;
Display_Border : Boolean := True;
Display_Filename : Boolean := True;
Display_Date : Boolean := True;
Ignore_Display_Parameters_For_Postscript : Boolean := True;
Highlight_Reserved_Words_For_Ada : Boolean := True;
Other_Options : String := "";
Number_Of_Copies : Positive := 1;
Printer : String := "<Default>";
Effort_Only : Boolean := False);
-- Prints one or more objects.
-- Additional parameters specify how the object(s) should be printed.
-- The printer used is based on the user via a map set up by the system manager.
--
-- The parameters have the following effects:
-- Object_Or_Image Specifies the object(s) to be printed. Can
-- designate (via value "<cursor>") mail messages,
-- I/O windows, etc.
-- If more than one object is specified, then the print
-- style is based on the first object in the list.
--
-- The following options only apply to printing on laser printers:
--
-- From_First_Page Have the first printed page be as specified, if
-- possible.
-- To_Last_Page Have the last printed page be as specified, if
-- possible.
--
-- Disply_As_Twoup Causes printing in 2-up format if possible
--
-- Display_Border Show a border around each page, if possible.
--
-- Display_Filename Show the filename being printed on each page, if
-- possible.
-- Display_Date Show the file date on each page, if possible.
--
--
-- Ignore_Display_Parameters_For_Postscript
-- If the object being printed is a PostScript file,
-- causes Display_Two_Up, Display_Date, Display_Filename,
-- and Display_Page_Border to be ignored.
--
-- Highlight_Reserved_Words_For_Ada
-- If the object being printed is Ada, use Ada format
-- which highlights keywords, italicizes comments, etc.
--
--
-- The following options apply to all files:
--
-- Other_Options Standard Queue.Print options can be
-- specified here. The options specified here
-- override any other option specifications.
-- The options from above will be combined with these
-- options, if they are still applicable.
--
-- Number_Of_Copies Prints the specified number of copies.
--
-- Printer Use the specified printer. By default, determine
-- the printer based on the user name. (each user
-- has a default printer).
-- Effort_Only If true, don't print anything, but check
-- parameter values and construct the command
-- that would be sent to the Queue.Print command.
--
-- To print a wide listing, in landscape mode on a laser printer, the
-- following options should be used:
--
-- Display_As_Twoup => False
-- Other_Options = "Postscript => (Wide,Spacing=10,Size=10)"
--
--
with Bounded_String;
with Common;
with Debug_Tools;
with Default;
with Directory;
with Directory_Tools;
with Io;
with Io_Exceptions;
with Library;
with Log;
with Object_Editor;
with Parameter_Parser;
-- with Print_Mailbox;
with Profile;
with Queue;
with String_Utilities;
with Switch_Implementation;
with System_Utilities;
with Time_Utilities;
procedure Print
(Object_Or_Image : String := "<CURSOR>";
From_First_Page : Positive := 1;
To_Last_Page : Positive := 3000;
Display_As_Twoup : Boolean := True;
Display_Border : Boolean := True;
Display_Filename : Boolean := True;
Display_Date : Boolean := True;
Ignore_Display_Parameters_For_Postscript : Boolean := True;
Highlight_Reserved_Words_For_Ada : Boolean := True;
Other_Options : String := "";
Number_Of_Copies : Positive := 1;
Printer : String := "<Default>";
Effort_Only : Boolean := False) is
package Bounded renames Bounded_String;
package Object renames Directory_Tools.Object;
package Naming renames Directory_Tools.Naming;
package Times renames Time_Utilities;
package Strings renames String_Utilities;
Objects_To_Print : Object.Iterator :=
Naming.Resolution (Name => Object_Or_Image,
Context => Naming.Default_Context,
Objects_Only => True);
Map_Filename : constant String := "!Machine.Queues.User_To_Printer_Map";
Error_Termination : exception;
-- Printable object types
type Kind_Of_Object is (Ada_Unit, Text_File, Postscript_File,
Image_File, Other_Kind);
-- These are the main printer options
-- Original_Raw, Raw, Postscript, and Format are mutually exclusive.
type Printer_Options is (Nil, Original_Raw, Postscript, Format,
Raw, Banner_Page_User_Text, Length,
Notify, Spool_Each_Item, Class, Copies);
package Option_Parser is
new Parameter_Parser
(Option_Id => Printer_Options,
Option_Kinds =>
"Original_Raw | Raw | Spool_Each_Item => Boolean," &
" others => Unspecified");
-- Format options for laser printers
Print_Two_Up_Format : Boolean := Display_As_Twoup;
Print_Page_Border : Boolean := Display_Border;
Print_Filename : Boolean := Display_Filename;
Print_Date : Boolean := Display_Date;
In_Reversed_Order : Boolean := False;
-- Global variables which determine the printer class, options, and format
To_Printer_Class : Bounded.Variable_String (200);
To_Printer_Options : Bounded.Variable_String (200);
Print_Laser : Boolean;
-- Temporary file for printing images
The_Time : Times.Time := Times.Get_Time;
Date_Image : constant String := Times.Image (Date => The_Time,
Date_Style => Times.Ada,
Time_Style => Times.Ada,
Contents => Times.Date_Only);
Time_Image : constant String := Times.Image (Date => The_Time,
Date_Style => Times.Ada,
Time_Style => Times.Ada,
Contents => Times.Time_Only);
Temp_Filename : constant String :=
"!Machine.Temporary." &
System_Utilities.User_Name & "_" & System_Utilities.Session_Name &
"_File_To_Print_On_" & Date_Image & "_At_" & Time_Image;
function Eq (A, B : String; Ignore_Case : Boolean := True) return Boolean
renames Strings.Equal;
function Get_Printer_Class return String is
begin
if Bounded.Length (To_Printer_Class) /= 0 then
return ", Class => " & Bounded.Image (To_Printer_Class);
else
return "";
end if;
end Get_Printer_Class;
function Squeeze (S : String) return String is
Result : String (1 .. S'Length);
Index : Natural := 1;
begin
for I in S'First .. S'Last loop
if S (I) /= ' ' then
Result (Index) := S (I);
Index := Index + 1;
end if;
end loop;
return Result (1 .. Index - 1);
end Squeeze;
-- Retrieve printer type based on user and Printer parameter.
procedure Get_Queue_Class is
F : Io.File_Type;
Next : Integer;
function Match (Pattern, Name : String) return Boolean is
begin
if Name'Length /= 0 and then Name (Name'First) = '*' then
return Eq (Pattern, Name);
elsif Eq (Pattern, "others") then
return True;
elsif Pattern = "@" then
return True;
else
return Eq (Pattern, Name);
end if;
end Match;
function Get_User_Printer (Printer : String) return String is
-- given the global printer parameter which is either <default> or
-- a printer name, return the string to search for in the user
-- to printer map file. If <default> this is the user name,
-- else it is the value of the parameter prefixed with an "*".
begin
if Eq (Printer, "<Default>") then
return System_Utilities.User_Name;
else
return "*" & Printer;
end if;
end Get_User_Printer;
function Token (S : String) return String is
Start, Stop : Natural;
begin
if Next = -1 then
Next := S'First; -- tricky initialization
end if;
Start := Next;
-- skip leading blanks
while Start <= S'Last and then S (Start) = ' ' loop
Start := Start + 1;
end loop;
Next := Start;
while Next <= S'Last and then S (Next) /= ' ' loop
Next := Next + 1;
end loop;
if Start <= S'Last then
if Next > S'Last then
Stop := S'Last;
else -- S (Next) = ' '
Stop := Next - 1;
end if;
return S (Start .. Stop);
else
return "";
end if;
end Token;
function Rest_Of_Line (S : String) return String is
Stop : Natural;
begin
Stop := Strings.Locate (Fragment => "--",
Within => S (Next .. S'Last));
if Stop = 0 then
Stop := S'Last;
else
Stop := Stop - 1;
end if;
return Strings.Strip (S (Next .. Stop));
end Rest_Of_Line;
begin
-- Check if it is an explicit printer name
if Strings.Locate ("!!", Printer, True) /= 0 then
Bounded.Copy (To_Printer_Class, Printer);
return;
end if;
-- Find printer information in the user printer map
declare
User : constant String := Get_User_Printer (Printer);
begin
Io.Open (F, Io.In_File, Map_Filename);
while not Io.End_Of_File (F) loop
Next := -1;
declare
Line : constant String := Io.Get_Line (F);
User_Name : constant String := Token (Line);
Class_Name : constant String := Token (Line);
Printer_Type : constant String := Token (Line);
Class_Options : constant String := Rest_Of_Line (Line);
begin
if User_Name'Length < 2 or else
User_Name (User_Name'First .. User_Name'First + 1) /=
"--" then
if Match (User_Name, User) then
Io.Close (F);
Bounded.Copy (To_Printer_Class, Class_Name);
Bounded.Copy (To_Printer_Options, Class_Options);
if Printer_Type = "Laser" then
Print_Laser := True;
else
Print_Laser := False;
end if;
return;
end if;
end if;
end;
end loop;
-- Didn't find a match!
Io.Close (F);
-- Report error
if User (User'First) = '*' then
Log.Put_Line
(Message =>
"The printer " & User (User'First + 1 .. User'Last) &
" does not exist. Please check the printer configuration" &
" file for possible names.",
Kind => Profile.Error_Msg,
Response => Profile.Get);
else
Log.Put_Line
(Message =>
"Could not print because no printer assignment has " &
"been made for you (" & User &
"). Contact your system manager. You can also " &
"specify an explicit printer name if you know one.",
Kind => Profile.Error_Msg,
Response => Profile.Get);
end if;
raise Error_Termination;
end;
exception
when Io_Exceptions.Name_Error =>
-- map file does not exist!
Bounded.Set_Length (To_Printer_Class, 0); -- try to use sys default
end Get_Queue_Class;
-- Returns the object type of This_Object_Name.
-- This is also passed wildcard expressions, and therefore only returns
-- the type of the first object in the list.
function Get_Object_Kind
(The_Object_List : in Object.Iterator) return Kind_Of_Object is
Ada : Object.Class_Enumeration renames Object.Ada_Class;
File : Object.Class_Enumeration renames Object.File_Class;
Text : Object.Subclass := Object.Value ("TEXT");
Postscript : Object.Subclass := Object.Value ("POSTSCRIPT");
The_Objects : Object.Iterator := The_Object_List;
This_Object : Object.Handle;
This_Object_Class : Object.Class_Enumeration;
This_Object_Subclass : Object.Subclass;
Temp : Io.File_Type;
First_Char : Character;
This_Kind : Kind_Of_Object;
Last_Kind : Kind_Of_Object := Other_Kind;
function "=" (Left, Right : in Object.Class_Enumeration) return Boolean
renames Object."=";
function "=" (Left, Right : in Object.Subclass) return Boolean
renames Object."=";
begin
Object.Reset (The_Objects);
loop
This_Object := Object.Value (The_Objects);
This_Object_Class := Object.Class (The_Object => This_Object);
This_Object_Subclass := Object.Subclass_Of
(The_Object => This_Object);
if This_Object_Class = Ada then
This_Kind := Ada_Unit;
elsif This_Object_Class = File then
This_Object_Subclass := Object.Subclass_Of
(The_Object => This_Object);
if This_Object_Subclass = Postscript then
This_Kind := Postscript_File;
else
begin
Io.Open (Temp, Io.In_File,
Naming.Full_Name (This_Object));
Io.Get (Temp, First_Char);
if (First_Char = '%') then
This_Kind := Postscript_File;
elsif This_Object_Subclass = Text then
This_Kind := Text_File;
else
This_Kind := Other_Kind;
end if;
Io.Close (Temp);
exception
when others =>
if This_Object_Subclass = Text then
This_Kind := Text_File;
else
This_Kind := Other_Kind;
end if;
Io.Close (Temp);
end;
end if;
else
This_Kind := Other_Kind;
end if;
if This_Kind /= Last_Kind then
if Last_Kind = Other_Kind then
Last_Kind := This_Kind;
else
This_Kind := Other_Kind;
end if;
end if;
Object.Next (The_Objects);
exit when Object.Done (The_Objects) or else This_Kind = Other_Kind;
end loop;
return This_Kind;
exception
when others =>
return Other_Kind;
end Get_Object_Kind;
-- Write an image to a temporary file
procedure Write_File (To_Filename : in String := Temp_Filename;
Retries : in Natural := 4) is
File : Io.File_Type;
begin
Io.Create (File => File,
Mode => Io.Out_File,
Name => To_Filename,
Form => "");
Io.Close (File => File);
Common.Write_File (Name => To_Filename);
exception
when Io.Use_Error =>
if Retries = 0 then
Io.Echo
("PRINT: Unable to print a window image " &
"(after retries, a USE_ERROR was encountered creating " &
Strings.Upper_Case (To_Filename) & ")");
raise Error_Termination;
else
delay 1.0; -- wait for library to get "unbusy"
Write_File (To_Filename => To_Filename,
Retries => Retries - 1); -- recursive!
end if;
end Write_File;
-- For printing mail messages.
function Spooled_As_Mail (This_Image : in String) return Boolean is
An_Object : Directory.Object;
Mailbox_Window_Id : constant String := "Mailboxes: ";
Status : Directory.Naming.Name_Status;
procedure Copy_Mail_Messages (From_Mailbox_Image : in String;
To_Text_File : in String;
With_One_Message_Per_Page : in Boolean) is
function Is_Main (Name : String) return Boolean is
begin
return Strings.Equal (Str1 => Name,
Str2 => Strings.Upper_Case (Name),
Ignore_Case => False);
end Is_Main;
function Find_Mailbox_Name (Image : String) return String is
Next_Blank : constant Natural := Strings.Locate (" ", Image);
Next_Lf : constant Natural := Strings.Locate (Ascii.Lf, Image);
begin
if (Image = "") or else (Next_Lf = Image'First) then
--
-- it's an empty image or there is no mailbox
--
raise Program_Error;
elsif (Next_Blank > Next_Lf or else Next_Blank = 0) and then
Next_Lf /= 0 then
-- it's multiple lines with the first line containing no blanks
--
if Is_Main (Image (Image'First .. Next_Lf - 1)) then
return Image (Image'First .. Next_Lf - 1);
else
raise Program_Error;
end if;
elsif Next_Blank /= 0 then
--
-- there is something else on the line beyond the next name
--
if Is_Main (Image (Image'First .. Next_Blank - 1)) then
return Image (Image'First .. Next_Blank - 1);
else
return Find_Mailbox_Name
(Image (Next_Blank + 1 .. Image'Last));
end if;
else
-- it's a single line with no blanks
--
if Is_Main (Image) then
return Image;
else
raise Program_Error;
end if;
end if;
end Find_Mailbox_Name;
function Mailbox_Name (Image : String) return String is
Next_Blank : constant Natural :=
Strings.Locate (Fragment => " ",
Within => Image,
Ignore_Case => True);
Next_Lf : constant Natural :=
Strings.Locate (Fragment => Ascii.Lf,
Within => Image,
Ignore_Case => True);
begin
if (Image = "") or else (Next_Lf = Image'First) then
--
-- either an empty image or no mailbox
--
return "";
elsif (Next_Blank = 0) and then (Next_Lf /= 0) then
--
-- multiple lines with the first line containing no blanks
--
if Is_Main (Image (Image'First .. Next_Lf - 1)) then
return Image (Image'First .. Next_Lf - 1);
else
return "";
end if;
elsif Next_Blank /= 0 then
--
-- something else on the line beyond the next name
--
if Is_Main (Image (Image'First .. Next_Blank - 1)) then
return Image (Image'First .. Next_Blank - 1);
else
return Find_Mailbox_Name
(Image (Next_Blank + 1 .. Image'Last));
end if;
else
-- a single line with no blanks
--
if Is_Main (Image) then
return Image;
end if;
end if;
return "";
end Mailbox_Name;
begin
Log.Put_Line ("Printing of mailboxes is not presently implemented.",
Profile.Error_Msg);
-- Print_Mailbox (To_File => To_Text_File,
-- One_Message_Per_Page => True,
-- Mailbox_Name =>
-- Find_Mailbox_Name
-- (Image => From_Mailbox_Image
-- (From_Mailbox_Image'First +
-- Mailbox_Window_Id'Length ..
-- From_Mailbox_Image'Last)));
--
end Copy_Mail_Messages;
begin
Object_Editor.Get_Object (Object => An_Object,
Status => Status,
Class => Directory.Nil,
Precision => Object_Editor.Image,
Job => Default.Process);
if Directory.Naming."/=" (Status, Directory.Naming.Successful) then
if Strings.Upper_Case (Object_Editor.Name) = "MAIL" then
declare
Image_String : constant String :=
Object_Editor.Get_Text
(Precision => Object_Editor.Image);
begin
if Image_String'Length > Mailbox_Window_Id'Length and then
Strings.Equal
(Str1 => Mailbox_Window_Id,
Str2 =>
Image_String (Image_String'First ..
(Image_String'First +
Mailbox_Window_Id'Length - 1)),
Ignore_Case => True)
then -- it's a mailbox image
Copy_Mail_Messages (From_Mailbox_Image => Image_String,
To_Text_File => Temp_Filename,
With_One_Message_Per_Page => True);
return True;
end if;
end;
end if;
end if;
return False;
end Spooled_As_Mail;
-- Setup printer options and make call to queue.print
procedure Queue_To_Print (The_Object_Name : in String;
The_Object_Iter : in Object.Iterator) is
-- Get the object type of the first element
Object_Kind : Kind_Of_Object := Get_Object_Kind (The_Object_Iter);
Option_String : Bounded.Variable_String (300);
-- Used to set the printer format
Iter : Option_Parser.Iterator := Option_Parser.Parse (Other_Options);
Format_Kind : Printer_Options := Nil;
procedure Add_Option (Image : String) is
begin
if Bounded.Length (Option_String) = 0 then
Bounded.Copy (Option_String, Image);
else
Bounded.Append (Option_String, ", " & Image);
end if;
end Add_Option;
begin
Bounded_String.Set_Length (Option_String, 0);
-- Only check these options when Other_Options is set
if Other_Options'Length /= 0 then
-- Check that Other_Options is correct
if not Option_Parser.Is_Successful (Iter) then
Log.Put_Line
(Message =>
"The Other_Options parameter could not be parsed" &
" because " & Option_Parser.Diagnosis (Iter),
Kind => Profile.Error_Msg,
Response => Profile.Get);
raise Error_Termination;
end if;
-- Add the basic printer options
declare
procedure Add_Main_Options (Option : Printer_Options) is
Image : constant String :=
Printer_Options'Image (Option) & " => " &
Option_Parser.Get_Image (Iter, Option);
begin
if Option_Parser.Is_Ok (Iter, Option) then
Add_Option (Image);
end if;
end Add_Main_Options;
begin
Add_Main_Options (Banner_Page_User_Text);
Add_Main_Options (Length);
Add_Main_Options (Notify);
Add_Main_Options (Spool_Each_Item);
end;
-- Check the mutually exclusive printer formats
declare
procedure Check_Option (Kind : Printer_Options) is
begin
if Option_Parser.Is_Ok (Iter, Kind) then
if Format_Kind /= Nil then
Log.Put_Line
(Message =>
"The Other_Options parameter contains conflicting formats: " &
Printer_Options'Image (Format_Kind) &
" & " & Printer_Options'Image (Kind),
Kind => Profile.Error_Msg,
Response => Profile.Get);
raise Error_Termination;
else
case Kind is
when Original_Raw | Raw =>
if Option_Parser.Get_Boolean
(Iter, Kind) then
Format_Kind := Kind;
else
Add_Option
("~" & Printer_Options'Image (Kind));
end if;
when Postscript | Format =>
Format_Kind := Kind;
when others =>
null;
end case;
end if;
end if;
end Check_Option;
begin
Check_Option (Original_Raw);
Check_Option (Raw);
Check_Option (Postscript);
Check_Option (Format);
end;
case Format_Kind is
when Original_Raw | Raw =>
Add_Option (Printer_Options'Image (Format_Kind));
when Postscript =>
if not Print_Laser then
Log.Put_Line
(Message =>
"You cannot use Postscript options " &
"in the Other_Options parameter because the currently " &
"selected printer is not a laser printer.",
Kind => Profile.Error_Msg,
Response => Profile.Get);
raise Error_Termination;
end if;
when Format =>
Add_Option
("Format => (" &
Option_Parser.Get_Image (Iter, Format_Kind) & ")");
when others =>
null;
end case;
end if;
-- Only set the following if format is nil or postscript and
-- printer is a laser printer
if (Format_Kind = Postscript) or
(Format_Kind = Nil and Print_Laser) then
-- Assemble the Options parameter using the following format:
--
-- POSTSCRIPT => ( FORMAT => [Autom{atic} | Fancy | Plain],
-- TWOUP => [True | False],
-- BORDER => [True | False],
-- FILENAME => [True | False],
-- DATE => [True | False],
-- PAGES => [1..Integer'Last]..[1..Integer'Last],
-- REVERSED => [True | False] ),
--
-- COPIES => [1..Natural'Last],
-- CLASS => [Laser | !!Machine_Name.Laser | ...]
--
--
declare
Options_Image : constant String :=
Option_Parser.Get_Image (Iter, Postscript);
Search_Image : constant String := Squeeze (Options_Image);
begin
-- add the options passed in Other_Options first
if Format_Kind = Postscript then
Add_Option ("Postscript => (" & Options_Image);
else
Add_Option ("Postscript => (");
end if;
-- always set format, don't use format variable
-- If format is set in Other_Options then ignore options
if Strings.Locate ("Format=", Search_Image, True) = 0 then
-- Set Format
if Format_Kind = Postscript then
Bounded.Append (Option_String, ", ");
end if;
Bounded.Append (Option_String, "Format => ");
if (Object_Kind = Postscript_File) then
Bounded.Append (Option_String, "PostScript");
elsif (Object_Kind = Ada_Unit) and then
Highlight_Reserved_Words_For_Ada then
Bounded.Append (Option_String, "Fancy");
elsif (Object_Kind = Text_File) or
(Object_Kind = Ada_Unit) then
Bounded.Append (Option_String, "Plain_Text");
else
Bounded.Append (Option_String, "Automatic");
end if;
-- Add the options passed in the Printer config file
if Bounded.Length (To_Printer_Options) /= 0 then
Add_Option (Bounded.Image (To_Printer_Options));
end if;
-- Add the rest of the options
if Object_Kind /= Postscript_File or else
not Ignore_Display_Parameters_For_Postscript then
if Strings.Locate ("Twoup", Search_Image, True) = 0 then
Add_Option ("Twoup => " &
Boolean'Image (Print_Two_Up_Format));
end if;
if Strings.Locate ("Border", Search_Image, True) =
0 then
Add_Option ("Border => " &
Boolean'Image (Print_Page_Border));
end if;
if Strings.Locate ("Filename", Search_Image, True) =
0 then
Add_Option ("Filename => " &
Boolean'Image (Print_Filename));
end if;
if Strings.Locate ("Date", Search_Image, True) = 0 then
Add_Option ("Date => " &
Boolean'Image (Print_Date));
end if;
end if;
if Strings.Locate ("Pages=", Search_Image) = 0 then
Add_Option ("Pages =>" &
Positive'Image (From_First_Page) & ".." &
Positive'Image (To_Last_Page));
end if;
end if;
-- Finish postscript options
Bounded.Append (Option_String, ")");
end;
elsif (Format_Kind = Nil) and then not Print_Laser then
-- No options are specified to a line printer then use the
-- System default
if Switch_Implementation.Is_Defined ("Queue.Options") then
Add_Option (Switch_Implementation.Value
(Switches => Switch_Implementation.Default_File,
Name => "Queue.Options"));
else
Add_Option ("Format => (System_Header, Wrap)");
end if;
end if;
-- Set the following for all objects and all printers
-- Set the number of copies
if Option_Parser.Is_Ok (Iter, Copies) then
Add_Option ("Copies => " & Option_Parser.Get_Image (Iter, Copies));
else
Add_Option ("Copies =>" & Positive'Image (Number_Of_Copies));
end if;
-- Set the printer class
if Option_Parser.Is_Ok (Iter, Class) then
Add_Option ("Class => " & Option_Parser.Get_Image (Iter, Class));
else
Bounded.Append (Option_String, Get_Printer_Class);
end if;
-- Print the object or display the call
if Effort_Only then
Io.Echo ("Queue.Print (Name => """ &
The_Object_Name & """, Options => """ &
Bounded_String.Image (Option_String) & """);");
else
Queue.Print (Name => The_Object_Name,
Options => Bounded_String.Image (Option_String),
Banner => "<DEFAULT>",
Header => "<DEFAULT>",
Footer => "<DEFAULT>");
end if;
end Queue_To_Print;
begin
-- determine if the object was resolvable
--
declare
Error_Category : Object.Category_Enumeration :=
Object.Category (Error_Code =>
Object.Err_Code (The_Objects =>
Objects_To_Print));
begin
case Error_Category is
when Object.Successful |
Object.Warning =>
Get_Queue_Class;
Queue_To_Print (Object_Or_Image, Objects_To_Print);
return;
when Object.Name_Error |
Object.No_Object |
Object.Selections_Not_Supported =>
--
-- seems to be a window image of some type
--
if not Spooled_As_Mail (This_Image => Object_Or_Image)
then -- spool as window image file
Write_File (To_Filename => Temp_Filename, Retries => 4);
end if;
Get_Queue_Class;
Objects_To_Print := Naming.Resolution (Temp_Filename);
Queue_To_Print (Temp_Filename, Objects_To_Print);
-- remove the temporary files
--
Library.Destroy (Existing => Temp_Filename,
Threshold => 1,
Limit => "<DIRECTORIES>",
Response => "");
return;
when Object.Cursor_Not_In_Selection |
Object.No_Declaration |
Object.No_Editor |
Object.No_Selection |
Object.Other_Error =>
Object.Report (The_Objects => Objects_To_Print,
Response => Profile.Get);
Log.Put_Line
(Message =>
"Could not print because no objects could be resolved" &
" (Status => " &
Object.Category_Enumeration'Image (Error_Category) &
")",
Kind => Profile.Error_Msg,
Response => Profile.Get);
when Object.Ambiguous_Name |
Object.Bad_Naming_Context |
Object.Ill_Formed_Name |
Object.Undefined_Name =>
Object.Report (The_Objects => Objects_To_Print,
Response => Profile.Get);
Log.Put_Line
(Message =>
"Could not print because one or more of the specified " &
"objects could not be resolved" & " (Status => " &
Object.Category_Enumeration'Image (Error_Category) &
")",
Kind => Profile.Error_Msg,
Response => Profile.Get);
when Object.Lock_Error =>
Object.Report (The_Objects => Objects_To_Print,
Response => Profile.Get);
Log.Put_Line
(Message =>
"Could not print because " &
"one or more of the specified objects are locked",
Kind => Profile.Error_Msg,
Response => Profile.Get);
when Object.Access_Error =>
Object.Report (The_Objects => Objects_To_Print,
Response => Profile.Get);
Log.Put_Line
(Message =>
"Could not print because this job does not have access " &
"to one or more of the specified objects",
Kind => Profile.Error_Msg,
Response => Profile.Get);
when Object.Version_Error =>
Object.Report (The_Objects => Objects_To_Print,
Response => Profile.Get);
Log.Put_Line
(Message =>
"Could not print because the required version is not " &
"available for one or more of the specified objects",
Kind => Profile.Error_Msg,
Response => Profile.Get);
when Object.Policy_Error =>
Object.Report (The_Objects => Objects_To_Print,
Response => Profile.Get);
Log.Put_Line
(Message =>
"Could not print because this operation violates " &
"a policy rule for one or more of the objects specified",
Kind => Profile.Error_Msg,
Response => Profile.Get);
when Object.Bad_Tree_Parameter |
Object.Class_Error |
Object.Code_Generation_Error |
Object.Consistency_Error |
Object.Illegal_Operation |
Object.Obsolescence_Error |
Object.Semantic_Error =>
Object.Report (The_Objects => Objects_To_Print,
Response => Profile.Get);
Log.Put_Line
(Message =>
"Could not print because an unexpected resolution " &
"error was encountered (Status => " &
Object.Category_Enumeration'Image (Error_Category) &
")",
Kind => Profile.Error_Msg,
Response => Profile.Get);
end case;
end;
exception
when Error_Termination =>
null;
when others =>
Log.Put_Line ("Unhandled exception: " & Debug_Tools.Get_Exception_Name,
Profile.Error_Msg);
end Print;
pragma Main;procedure Print_Window (Options : String := "<DEFAULT>";
Banner : String := "<DEFAULT>";
Header : String := "<DEFAULT>";
Footer : String := "<DEFAULT>");
-- Copies the content of the current window (its image) into a temporary
-- file, prints that file using queue.print, then destroys that file.
-- The file is named !machine.temporary.<User_Name>_<Job_Number>_<Window_Type>with Common;
with Library;
with Object_Editor;
with Queue;
with String_Utilities;
with System_Utilities;
procedure Print_Window (Options : String := "<DEFAULT>";
Banner : String := "<DEFAULT>";
Header : String := "<DEFAULT>";
Footer : String := "<DEFAULT>") is
File_Name : constant String :=
"!machine.temporary." & System_Utilities.User_Name & '_' &
String_Utilities.Number_To_String
(Integer (System_Utilities.Get_Job)) & '_' & Object_Editor.Name;
begin
Common.Write_File (Name => File_Name);
Queue.Print (Name => File_Name,
Options => Options,
Banner => Banner,
Header => Header,
Footer => Footer);
Library.Destroy (Existing => File_Name,
Threshold => 1,
Limit => "<DIRECTORIES>",
Response => "<PROFILE>");
end Print_Window;
pragma Main;procedure Run_Job (S : String := "<SELECTION>";
Debug : Boolean := False;
Context : String := "$";
After : Duration := 0.0;
Options : String := "";
Response : String := "<PROFILE>");
pragma Main;with Program;
procedure Run_Job (S : String := "<SELECTION>";
Debug : Boolean := False;
Context : String := "$";
After : Duration := 0.0;
Options : String := "";
Response : String := "<PROFILE>") is
begin
Program.Run_Job (S, Debug, Context, After, Options, Response);
end Run_Job;procedure Schedule_Shutdown (At_Time : String := "23:59";
Reason : String := "COPS";
Explanation : String := "Cause not entered");
pragma Main;with Operator;
with Log;
with Time_Utilities;
with Calendar;
with Profile;
procedure Schedule_Shutdown (At_Time : String := "23:59";
Reason : String := "COPS";
Explanation : String := "Cause not entered") is
use Time_Utilities;
T : Time;
function Time_Ok return Boolean is
use Calendar;
begin
if Convert_Time (T) < Clock then
return False;
else
return True;
end if;
end Time_Ok;
begin
T := Value (At_Time);
if Time_Ok then
Operator.Shutdown_Warning (Interval => Duration_Until (T));
Operator.Show_Shutdown_Settings;
Operator.Shutdown (Reason => Reason, Explanation => Explanation);
else
Log.Put_Line ("ERROR - Specification of a past time not allowed.");
end if;
exception
when others =>
Log.Put_Line
("ERROR - Illegal Date/Time. Use YR/MO/DA HR:MIN:SEC form.",
Profile.Error_Msg);
end Schedule_Shutdown;procedure Secondary_Backup (Starting_At : String := "");
pragma Main;with Do_Backup;
with System_Backup;
procedure Secondary_Backup (Starting_At : String := "") is
begin
Do_Backup (Variety => System_Backup.Secondary, Starting_At => Starting_At);
end Secondary_Backup;procedure Sedit (Switch_File : String := "<SWITCH>");
pragma Main;with Switches;
procedure Sedit (Switch_File : String := "<SWITCH>") is
begin
Switches.Edit (Switch_File);
end Sedit;procedure Sledit (Session : String := ""; User : String := "");
pragma Main;with Search_List;
procedure Sledit (Session : String := ""; User : String := "") is
begin
Search_List.Show_List (Session, User);
end Sledit;procedure Ssedit (Switch_File : String := "<SESSION>");
pragma Main;with Switches;
procedure Ssedit (Switch_File : String := "<SESSION>") is
begin
Switches.Edit (Switch_File);
end Ssedit;procedure Users (Jobs_Too : Boolean := False; Verbose : Boolean := False);
pragma Main;with Io;
with Table_Formatter;
with Time_Utilities;
with Scheduler;
with String_Utilities;
with System_Utilities;
procedure Users (Jobs_Too : Boolean := False; Verbose : Boolean := False) is
use System_Utilities;
use Io;
package Tu renames Time_Utilities;
function Image (Value : Long_Integer;
Base : Natural := 10;
Width : Natural := 0;
Leading : Character := ' ') return String
renames String_Utilities.Number_To_String;
Output : File_Type := Current_Output;
S : Session_Iterator;
J_Iter : Job_Iterator;
function Elapsed (For_Job : Job_Id) return String is
begin
return Tu.Image (Elapsed (For_Job));
end Elapsed;
function Trim (S : String; Width : Natural; Left : Boolean := False)
return String is
begin
if S'Length > Width then
if Left then
return S (S'Last - Width .. S'Last);
else
return S (S'First .. S'First + Width);
end if;
else
return S;
end if;
end Trim;
function Name (S : Session_Id) return String is
begin
return User_Name (S) & '.' & Session_Name (S);
end Name;
procedure Show_Sessions is
package Tf is new Table_Formatter (5);
use Tf;
procedure Display_Session (S : Session_Id) is
J : Job_Iterator;
Displayed : Boolean := False;
begin
Item (Name (S));
Item (Port'Image (System_Utilities.Terminal (S)));
Init (J, S);
while not Done (J) loop
declare
use Scheduler;
begin
if Get_Job_Kind (Value (J)) = Scheduler.Ce then
Item (Image (Long_Integer (Value (J))));
Item (Tu.Image (Elapsed (Value (J))));
Displayed := True;
exit;
end if;
end;
Next (J);
end loop;
if not Displayed then
Item ("?");
Item ("?");
end if;
Item (Image (Input_Count (System_Utilities.Terminal (S))) & "/" &
Image (Output_Count (System_Utilities.Terminal (S))));
end Display_Session;
begin
Header ("Session");
Header ("Line", Right);
Header ("Job", Right);
Header ("Time", Right);
Header ("IO Count", Centered);
Init (S);
while not Done (S) loop
Display_Session (Value (S));
Next (S);
end loop;
Sort;
Display (Output);
end Show_Sessions;
procedure Show_Jobs is
package Tf is new Table_Formatter (5);
use System_Utilities;
J : System_Utilities.Job_Iterator;
begin
Io.New_Line;
Tf.Header ("Owner");
Tf.Header ("Job");
Tf.Header ("Elapsed", Tf.Right);
Tf.Header ("CPU", Tf.Right);
Tf.Header ("Job Name");
Init (S);
while not Done (S) loop
System_Utilities.Init (J, Value (S));
while not Done (J) loop
Tf.Item (Trim (Name (Value (S)), 14, Left => False));
Tf.Item (Image (Long_Integer (Value (J)))); -- job #
Tf.Item (Trim (Elapsed (Value (J)), 8, Left => False));
Tf.Item (Trim (Tu.Image (System_Utilities.Cpu (Value (J))), 8,
Left => False));
Tf.Item (Trim (Job_Name (Value (J)), 37, Left => False));
Next (J);
end loop;
Next (S);
end loop;
Tf.Sort;
Tf.Display (Output);
end Show_Jobs;
begin
Io.Put_Line (Output, "Rational Environment " &
System_Utilities.System_Boot_Configuration &
", Last boot: " &
Tu.Image (Tu.Convert_Time
(System_Utilities.System_Up_Time)));
Io.New_Line;
Show_Sessions;
if Jobs_Too then
Show_Jobs;
end if;
end Users;
pragma Main;procedure Vlist (Pattern : String := "@";
Descending : Boolean := False;
Response : String := "<PROFILE>";
Options : String := "");
pragma Main;with Library;
procedure Vlist (Pattern : String := "@";
Descending : Boolean := False;
Response : String := "<PROFILE>";
Options : String := "") is
begin
Library.Verbose_List (Pattern,
Descending => Descending,
Response => Response,
Options => Options);
end Vlist;
pragma Main;package Access_List is
subtype Name is String; -- an object name
Read : constant Character := 'R'; -- objects and worlds
Write : constant Character := 'W'; -- objects only
Delete : constant Character := 'D'; -- worlds only; same bit as W
Create : constant Character := 'C'; -- worlds only
Owner : constant Character := 'O'; -- worlds only
subtype Acl is String;
-- String representations of access lists have the following syntax:
-- Acl ::= Acl_Entry [',' Acl_Entry]*
-- Acl_Entry ::= Group '=>' Access
-- Group ::= Identifier
-- Access ::= Acc_Type+
-- Acc_Type ::= 'R' | 'W' | 'D' | 'C' | 'O' |
-- 'r' | 'w' | 'd' | 'c' | 'o'
-- Examples: "Phil => R , TRW => rw", "Public=>RCOD"
procedure Display (For_Object : Name := "<CURSOR>");
-- Display the access list of the specified object(s).
-- Output and error messages are send to current output.
procedure Set (To_List : Acl := "Network_Public => RWCOD";
For_Object : Name := "<SELECTION>";
Response : String := "<PROFILE>");
-- Set the access list for the specified object(s).
-- Setting the access list requires "Owner" access to the containing world.
-- Sends messages to a log that is under control of the Response parameter.
procedure Default_Display (For_World : Name := "<CURSOR>");
-- Display the default acl of the specified world(s) in an output window.
-- Error messages are sent to the window in case of any error.
-- Wildcards in the name are allowed.
-- Non-world objects are filtered out of the display.
-- A null display is produced if no worlds are referenced.
procedure Set_Default (To_List : Acl := "Network_Public => RW";
For_World : Name := "<SELECTION>";
Response : String := "<PROFILE>");
-- Set the default ACL for the specified world(s).
-- Owner access to each world is required.
-- Sends messages to a log that is under control of the Response parameter.
-- A log is written indicating success or errors.
-- Wildcards are allowed in the name.
-- Any non-world objects referenced are ignored.
-- A summary of the number of objects affected is included in the log.
procedure Add (To_List : Acl := "Network_Public => RWCOD";
For_Object : Name := "<SELECTION>";
Response : String := "<PROFILE>");
-- Add the access list to the existing value for the specified object(s).
-- Changing the access list requires "Owner" access to the containing world.
-- Sends messages to a log that is under control of the
-- Response parameter.
procedure Add_Default (To_List : Acl := "Network_Public => RW";
For_World : Name := "<SELECTION>";
Response : String := "<PROFILE>");
-- Add the default ACL to the existing value for the specified world(s).
-- Owner access to each world is required.
-- Sends messages to a log that is under control of the Response parameter.
-- A log is written indicating success or errors.
-- Wildcards are allowed in the name.
-- Any non-world objects referenced are ignored.
-- A summary of the number of objects affected is included in the log.
procedure Remove (Group : String := ">>SIMPLE NAME<<";
For_Object : Name := "<SELECTION>";
Response : String := "<PROFILE>");
--
-- Remove the group from the specified object(s)' access list(s).
-- Changing the access list requires "Owner" access to the containing
-- world. Sends messages to a log that is under control of the
-- Response parameter.
procedure Remove_Default (Group : String := ">>SIMPLE NAME<<";
For_World : Name := "<SELECTION>";
Response : String := "<PROFILE>");
--
-- Remove the group from the specified world(s)' default access list(s).
-- Owner access to each world is required. Sends messages to the log that
-- is under control of the Response parameter. Wildcards are allowed
-- in the name. Any non-world objects referenced are ignored.
-- A summary of the number of objects affected is included in the log.
pragma Subsystem (Os_Commands);
pragma Module_Name (4, 3507);
end Access_List;with Action;
with Directory;
with Machine;
package Action_Utilities is
procedure Display_Action (Id : Action.Id);
procedure Display_Action (Id : Integer);
-- displays either not in progress or put_task_info (creating task_id)
-- the second form converts the integer to an action.id and
-- invokes the first form
procedure Lock_Information (Version : Directory.Version);
procedure Lock_Information
(Name : Directory.Naming.Name := "<Image>";
Version : Directory.Version_Name := Directory.All_Versions);
-- displays the following information
-- actions (if any) that have a read lock on the version
-- action (if any) that has an update lock on the version
-- action (if any) that has an overwrite lock on the version
-- request queue of [task,action,mode] triples waiting for the object
-- the second form does name resolution and then calls the first form
procedure Display_Task (Task_Id : Machine.Task_Id);
-- shows the user, session and job for the specified task
procedure Display_Object (Version : Directory.Version);
procedure Display_Object
(Class : Natural; Instance : Natural; Host : Machine.Id);
-- displays the name and version of the specified object
-- the second form construct a directory.version and calls the first form
procedure Lock_Information
(Class : Natural; Instance : Natural; Host : Machine.Id);
pragma Subsystem (Os_Commands);
pragma Module_Name (4, 3933);
end Action_Utilities;package Activity is
pragma Subsystem (Commands);
pragma Module_Name (4, 3940);
subtype Activity_Name is String;
-- An Activity is a managed object that maintains a map between
-- subsystems and pairs of views. The pair consists of a spec view and
-- a load (non-spec) view of the subsystem. An activity name is a
-- string name for the managed object. The view pair can be specified
-- indirectly by associating a subsystem in one activity with another
-- activity, which then maps the subsystem to a pair of views.
-- In these Activity commands, the default Activity is the object
-- selected in the accompanying window, the object associated with the
-- accompanying window, or, as a last resort, The_Current_Activity.
type Creation_Mode is (Differential, Exact_Copy, Value_Copy);
-- When a subsystem is copied from one Activity to another, the entry
-- in the destination activity can be created in three ways:
-- Differential : In the destination activity, the subsystem is mapped
-- to the source Activity.
-- Exact_Copy : In the destination activity, the subsystem is mapped
-- to the same object it mapped to in the source
-- activity; this may be either a view or an activity.
-- Value_Copy : In the destination activity, the subsystem is mapped
-- to the view currently associated with the subsystem
-- in the source activity.
subtype Subsystem_Name is String;
-- String name of a World directory.
subtype View_Simple_Name is String;
subtype View_Name is String;
-- View_Name = Subsystem_Name & '.' & View_Simple_Name
-- A View is a world whose enclosing world is a Subsystem world.
-- Any number of directories may come between a view and its subsystem.
-- Hence, the view's subsystem is implicit in the full name of the
-- view. The simple name of the view is used where the name of the
-- subsystem is easily derived from other parameters.
subtype View_Or_Activity_Name is String;
-- An activity can be used to indirectly specify a view.
subtype Unit_Name is String;
-- The string name for an Ada library unit nested within a view of a
-- subsystem.
function Nil return Activity_Name;
-- The name of the canonical activity with no subsystems;
-- the empty activity.
procedure Current (Response : String := "<PROFILE>");
-- Prints the name of the activity currently associated with the
-- running job; if no Activity has been associated with the job, it
-- then returns the Activity currently associated with the running
-- sesssion.
function The_Current_Activity return Activity_Name;
-- returns the name of the current activity; as defined above.
procedure Set (The_Activity : Activity_Name := "<ACTIVITY>";
Response : String := "<PROFILE>");
-- Makes The_Activity the current activity for the running job only.
procedure Set_Default (The_Activity : Activity_Name := "<ACTIVITY>";
Response : String := "<PROFILE>");
-- Makes Activity the current activity for the session. If the job's
-- activity is nil, set that as well.
procedure Enclosing_View (Unit : Unit_Name := "<IMAGE>";
Response : String := "<PROFILE>");
-- Prints the name of the enclosing view (either a load or spec view);
function The_Enclosing_View
(Unit : Unit_Name := "<IMAGE>") return View_Name;
-- The name of the enclosing view (either a load or spec view);
procedure Enclosing_Subsystem (View : View_Name := "<IMAGE>";
Response : String := "<PROFILE>");
-- Prints the name of the subsystem that encloses the View, which may
-- be either a Spec or Load view.
function The_Enclosing_Subsystem
(View : View_Name := "<IMAGE>") return Subsystem_Name;
-- The name of the subsystem that encloses the View, which may
-- be either a Spec or Load view.
procedure Create (The_Activity : Activity_Name := ">>ACTIVITY NAME<<";
Source : Activity_Name := Activity.Nil;
Mode : Creation_Mode := Activity.Exact_Copy;
Response : String := "<PROFILE>");
-- Create a new Activity object. If the Source activity is not Nil,
-- its contents are copied to the new activity according to the
-- specified Mode.
procedure Add (Subsystem : Subsystem_Name := "<CURSOR>";
Load_Value : View_Or_Activity_Name := Activity.Nil;
Spec_Value : View_Or_Activity_Name := Activity.Nil;
The_Activity : Activity_Name :=
Activity.The_Current_Activity;
Mode : Creation_Mode := Activity.Exact_Copy;
Response : String := "<PROFILE>");
-- Add a subsystem to an existing Activity. If the load or spec values
-- are activities, the mapping is created according to the specified
-- mode. The Load_Value and Spec_Value names are resolved in the
-- context of the given Subsystem, so that View_Simple_Names may be
-- used.
procedure Remove (Subsystem : Subsystem_Name := "<SELECTION>";
The_Activity : Activity_Name :=
Activity.The_Current_Activity;
Response : String := "<PROFILE>");
-- Remove a subsystem from an Activity.
procedure Set_Spec_View (Spec_View : View_Or_Activity_Name := "<CURSOR>";
Subsystem : Subsystem_Name := "";
Mode : Creation_Mode := Activity.Differential;
The_Activity : Activity_Name :=
Activity.The_Current_Activity;
Response : String := "<PROFILE>");
-- If Spec_View designates a view, associates the given view as the spec
-- view for the subsystem that contains the view.
-- If Spec_View designates an activity, associates the spec view defined
-- in the given source activity as the new spec view of the given
-- subsytem in the destination Activity. The mapping is created
-- according the given Mode.
-- The Spec_View parameter is resolved in the context established by the
-- Subsystem parameter. The subsystem is derived from the Spec_View
-- parameter if it denotes a view, otherwise the Subsystem parameter
-- must be given.
procedure Set_Load_View (Load_View : View_Or_Activity_Name := "<CURSOR>";
Subsystem : Subsystem_Name := "";
Mode : Creation_Mode := Activity.Differential;
The_Activity : Activity_Name :=
Activity.The_Current_Activity;
Response : String := "<PROFILE>");
-- If Load_View designates an activity, associates the given View as the
-- load view for the subsystem that contains the view.
-- If Load_View designates an activity, associates the load view defined
-- in the given Source activity as the new load view of the given
-- subsystem in the named Activity. The mapping is created according the
-- given Mode.
-- The Load_View parameter is resolved in the context established by the
-- Subsystem parameter. The subsystem is derived from the Load_View
-- parameter if it denotes a view, otherwise the Subsystem parameter
-- must be given.
procedure Display (Subsystem : Subsystem_Name := "?";
Spec_View : View_Name := "?";
Load_View : View_Name := "?";
Mode : Creation_Mode := Activity.Value_Copy;
The_Activity : Activity_Name :=
Activity.The_Current_Activity;
Response : String := "<PROFILE>");
-- Display the mappings between subsystems and views defined by the
-- given activity. Only the mappings that match the patterns given in
-- the Subsystem, Spec_View, and Load_View parameters are listed. (The
-- default is to list all mappings in the activity.) In the Value_Copy
-- mode, all indirect references are resolved and only the resolution
-- is displayed. In the Exact_Copy mode, Indirect mappings are not
-- resolved and the name of the source activity is displayed. In the
-- Differential mode, the indirect mappings are resolved and both the
-- resolution and the original indirect activity are displayed.
procedure Edit (The_Activity : Activity_Name := "<ACTIVITY>");
-- Invoke the Activity object editor on the given Activity.
procedure Insert (Subsystem : Subsystem_Name := ">>SUBSYSTEM NAME<<";
Spec_View : View_Or_Activity_Name := "";
Load_View : View_Or_Activity_Name := "");
-- Inserts the specified subsystem mapping into the activity associated
-- with the command window. (The current activity is brought up in an
-- Activity window and modified if the command is not associated with
-- an Activity window). The given names may specify a view or another
-- activity. If the subsystem name is omitted, it is inferred from the
-- view names.
procedure Change (Spec_View : View_Or_Activity_Name := "";
Load_View : View_Or_Activity_Name := "");
-- The selected subsystem mapping is changed to the new values given in
-- the Views specification. Valid only in an Activity window.
procedure Write (File : Activity_Name := ">>ACTIVITY NAME<<");
-- Copies the current content of the Activity window to the designated
-- File. Valid only in an Activity window.
procedure Visit (The_Activity : Activity_Name := "<ACTIVITY>");
-- Same as Edit, except that if the command is given on an activity
-- window, the new activity is displayed in that window rather than in
-- a new one.
procedure Merge (Source : Activity_Name := ">>ACTIVITY NAME<<";
Subsystem : Subsystem_Name := "?";
Spec_View : View_Name := "?";
Load_View : View_Name := "?";
Mode : Creation_Mode := Activity.Exact_Copy;
Target : Activity_Name := "<ACTIVITY>";
Response : String := "<PROFILE>");
-- The subsystem mappings defined in the Source Activity that match the
-- given subsystem and view patterns are copied to the Target activity
-- according to the specified Creation mode. New subsystems are added
-- to the Target activity if necessary; Existing subsystem mappings are
-- replaced. The default Target activity is the current selection/image.
end Activity;package Ada is
procedure Code_Unit;
-- Bring the unit corresponding to current image to the coded state.
-- May involve coding subunits, parent unit, or corresponding visible
-- part, but no closure operation is performed. If the operation
-- succeeds, the unit will be read-only.
procedure Install_Unit;
-- Bring the unit corresponding to current image to the installed
-- state. Will install no other units; may reduce subunits or parent
-- unit to installed, but no closure operation is performed. If the
-- operation succeeds, the unit will be read-only.
procedure Source_Unit;
-- Bring the unit to source state such that its library declaration has
-- the appropriate name and the image is read-only.
procedure Withdraw (Name : String := "<IMAGE>");
-- Edit the indicated unit, removing its declaration from the library.
procedure Diana_Edit (Name : String := "<CURSOR>");
-- Show a read-only image of the internal form of the Diana tree
-- corresponding to the image given.
procedure Install_Stub;
-- Make the stub for the current compilation unit have the real name
-- of the unit rather than its _Ada_nn_ name.
procedure Make_Inline;
-- Make a separate subunit body into an inline unit body
procedure Make_Separate;
-- Make an inline subunit body be a separate subunit body
procedure Other_Part (Name : String := "<IMAGE>";
In_Place : Boolean := False);
-- If a new window is required, In_Place indicates that the current
-- frame should be used.
procedure Replace_Id (Old_Id : String := ">>OLD NAME<<";
New_Id : String := ">>NEW NAME<<");
-- For the current selection, change all occurrences of Old_ID into
-- occurrences of New_ID. Only changes Ada identifier references that
-- match exactly.
procedure Show_Usage (Name : String := "<CURSOR>";
Global : Boolean := True;
Limit : String := "<ALL_WORLDS>";
Closure : Boolean := False);
-- Show uses of the indicated item.
-- Global => mark units other than the one indicated.
-- Limit specifies the range of units if Global is true.
-- Closure causes Show_Usage to find indirect references, e.g. renames.
procedure Show_Unused (In_Unit : String := "<IMAGE>";
Check_Other_Units : Boolean := True);
-- Show the declarations in a unit that are not referenced
procedure Create_Body (Name : String := "<IMAGE>");
-- Create a body declaration corresponding to the indicated
-- declaration or visible part.
procedure Create_Private (Name : String := "<IMAGE>");
-- Create a private part declaration for each private type that still
-- requires one.
procedure Get_Errors;
-- Restore the error underlining from the last compile, semanticize,
-- etc.
procedure Insert_Blank_Line (Repeat : Positive := 1);
-- Insert repeat blank lines before the current line
procedure Delete_Blank_Line (Repeat : Positive := 1);
-- Delete repeat blank lines at the current cursor
procedure Expand_Names (Name : String := "<SELECTION>";
Prefix_Standard : Boolean := False;
Prefix_Unit : Boolean := False;
Expand_Operators : Boolean := False);
-- Expands names in the named Ada fragment. Prefix_Standard causes
-- names from Standard to get prefixed. Prefix_Unit causes names
-- from the current unit to get prefixed. Expand_Operators causes
-- operators (such as "=" and "+") to get prefixed.
pragma Subsystem (Command);
pragma Module_Name (4, 2209);
end Ada;with Machine;
package Archive is
procedure Save (Objects : String := "<IMAGE>";
Options : String := "R1000";
Device : String := "MACHINE.DEVICES.TAPE_0";
Response : String := "<PROFILE>");
-- Save a set of objects (files, Ada units, etc.) to a tape or directory
-- such that they may be restored to their original form at a later time
-- or on another system.
-- The Objects parameter specifies the primary objects to be saved. It
-- can be any naming expression. By default, the current image is saved
-- unless there is a selection on that image, in which case the selected
-- object is saved. Normally, the specified object(s) and all contained
-- objects are archived; this feature can be disabled.
-- The Options parameter specifies the type of tape to be written and
-- options to control what is saved. The Options parameter for each of
-- the Archive operations is written as a sequence of option
-- names separated by spaces or commas. Options with arguments are
-- given as an option name followed by an equal sign followed by a
-- value.
---------------------------------------------------------------------------
-- The save options are:
--
-- FORMAT = R1000 | R1000_LONG | ANSI
-- R1000
-- Writes an ANSI tape with the data file followed by the index
-- file. The images of the objects being saved are written
-- directly to the tape. This is the default.
-- R1000_LONG
-- like R1000 format but the data file is written to one ANSI tape
-- and the index file to a second ANSI tape.
-- ANSI
-- Writes the data to a temporary file and then writes both index
-- and data file to a tape using ANSI tape facilities.
-- LABEL=(<any balanced string>)
-- An identifying string written at the head of the archived data.
-- The label parameter allows the user to specify a string that
-- will be put at the front of the index file. When a restore is
-- done the label specified to the restore procedure will be
-- checked against the one on the save tape.
-- NONRECURSIVE
-- Save only the objects resolved to by the Objects parameter. Do
-- not recursively save objects that are inside of other objects.
-- The default is to save the objects mentioned in the Objects
-- parameter and all objects contained in them.
-- To save a world and a subset of its contents one can say:
-- Save (Objects => "[!FOO?,~!FOO.ABC?,~!FOO.DEF?]", ...,
-- Options => "R1000 NONRECURSIVE");
-- AFTER=<time_expression>
-- Only objects changed after the time represented by
-- <time_expression> will be archived. The <time_expression>
-- should be acceptable to the time_utilities.value function.
-- STARTING_AT=<time_expression>
-- the archive will delay until the given time
-- (after the mount request has been processed).
-- EFFORT_ONLY
-- The EFFORT_ONLY option causes a list to be printed of the names
-- of the units that would be saved if the archive command
-- was given with this set of parameters.
-- CODE [=load_proc_list]
-- The CODE option specifies that code is to be archived for the
-- named load procs. If no specification follows the
-- CODE option, the Objects parameter specification is used
-- instead.
-- COMPATIBILITY_DATABASE (CDB) [=<Subsystems>]
-- Causes the full compatibility database for each subsystem
-- specified to be archived. If no subsystems are specified with
-- the option, the Objects parameter specification is used instead.
-- When Ada units in a subsystem are archived, the relevant
-- portions of the subsystem Compatibility Database is
-- automatically archived with them. Therefore, this option is
-- required only in special situations, primarily when one needs to
-- "sync up" a primary and a secondary subsystem.
-- To archive just Compatibility Databases, use
-- Save ("Subsystems", "CDB");
-- To archive compatibility databases with other objects, use
-- Save ("Other Stuff", "CDB=Subsystems");
-- The "Subsystems" and "Other Stuff" specifications will usually
-- describe disjoint sets of objects.
-- IGNORE_CDB
-- Specifies that no compatibility database information is to be
-- saved.
-- LINKS [=<worlds>]
-- Causes only the link pack for each world specified to be archived.
-- If no worlds are specified with the option, the Objects
-- parameter specification is used instead.
-- PREFIX=<naming pattern>
-- A naming pattern that is saved with the archived objects, which
-- can be recalled as the For_Prefix when the data is Restored.
-- When set to an appropriate value, the restorer need not know
-- exactly the names of the archived objects to be able to restore
-- them to a new place. If this option is not given, the value
-- used is derived from the Objects parameter.
-- UNLOAD
-- A boolean option. When True (the default), causes the tape to
-- be rewound and unloaded after the operation is complete. When
-- False, this option causes the tape to be rewound to the beginning
-- and to remain online and available for subsequent requests.
-- When the tape is left online, subsequent requests send a tape-
-- mount request to the operator's console, which must be answered
-- before the tape can be accessed.
-- For downward compatibility the following options are provided.
--
-- DELTA0
-- write a tape which can be read on a delta0 system.
--
-- DELTA1
-- write a tape which can be read on a delta1 system.
--
-- VERSION=<archive_version_number>
-- write a tape that can be read by a version of source
-- earlier than the current one. The argument is a three digit
-- integer. For example, version=440.
-- The Device parameter can be set to the name of a directory. In this
-- case the index and data files are written to that directory. The
-- tape format option is irrelevant in this case.
---------------------------------------------------------------------------
procedure Restore (Objects : String := "?";
Use_Prefix : String := "*";
For_Prefix : String := "*";
Options : String := "R1000";
Device : String := "MACHINE.DEVICES.TAPE_0";
Response : String := "<PROFILE>");
-- Restore an object or a set of objects from an Archive Tape.
-- If the archive is on a tape then the tape format option given to
-- Restore should be the same as that given during the save. If the
-- archive is in a directory then the device parameter on the restore
-- should be set to that directory.
-- The Objects parameter may be any wildcard pattern specifying the
-- objects to be restored.
--
-- For example:
-- !USERS.FOO.CLI.TEST
-- [!USERS.FOO.TESTS.@, !USERS.FOO.LOGS.ABC]
-- The pattern in the Objects parameter is compared against the full
-- names of the saved objects. The objects whose names match the Objects
-- parameter specification are restored. If the name denotes an Ada
-- unit all of its parts are restored from the tape. If the name denotes
-- a world or directory all of its subcomponents are restored.
-- The Use_Prefix and For_Prefix parameters provide a simple means for
-- changing the names of the archived objects when they are restored.
-- If the Use_Prefix is the special default value, "*", the For_Prefix
-- is ignored and the objects are restored using the names they had when
-- they were saved.
-- If the Use_Prefix is not "*", it must specify the name of an object
-- into which the archived objects can be restored. The name for a
-- restored object is derived from the name of the archived object by
-- replacing the shortest portion of the name matched by the For_Prefix
-- with the value of the Use_Prefix. If the For_Prefix is "*" the
-- archived objects are restored using the Default_Prefix stored with
-- the archived data.
-- For example:
--
-- Restore (Objects => "!A.B.C.D.E",
-- Use_Prefix => "!X.Y",
-- For_Prefix => "!A.B.C");
--
-- will restore to !X.Y.D.E.
-- The For_Prefix may contain wildcard characters (#, @, ?) and the
-- Use_Prefix parameter may contain substitution characters (@ or # only).
-- For example:
--
-- Restore (Objects => "[!A.B.TEST1, !D.E.F.TEST2]"
-- For_Prefix => "?.@"
-- Use_Prefix => "!C.D.@");
--
-- will restore to !C.D.TEST1 and !C.D.TEST2
-- If the object named by the prefix of the target name of an object
-- being restored doesn't exist, that object will be created as a set of
-- nested libraries. So, for example, if the For_Prefix is !A.B and the
-- unit being restored is then !A.B.X.Y.Z and ...X.Y hasn't been saved on
-- the tape then !A, !A.B, !A.B.X, !A.B.X.Y will be created.
---------------------------------------------------------------------------
-- The following options are allowed in the Options parameter:
--
-- FORMAT and LABEL
-- as in the save option.
-- NONRECURSIVE
-- prevents subcomponents of libraries and Ada units from being
-- implicitly restored. for example:
-- Archive.Restore
-- (Objects => "[!USERS.FOO, !USERS.FOO.CLI, !USERS.FOO.CLI.@]",
-- Options => "R1000 NONRECURSIVE");
-- will restore only the named objects and not their substructure.
-- ALL_OBJECTS
-- All specified objects are restored. This is the default.
-- NEW_OBJECTS
-- Only specified objects that don't already exist on the target
-- machine are restored.
-- UPDATED_OBJECTS
-- Only specified objects that already exists on the target are
-- restored, but only if the update time of the archived object
-- is greater than the update time on the target object.
-- CHANGED_OBJECTS
-- Restore both new and updated Objects.
-- EXISTING_OBJECTS
-- Only specified objects that already exists on the target
-- are restored.
-- DIFFERENT_OBJECTS
-- Only specified objects that already exists on the target
-- and have a different update time from the archived object are
-- restored.
-- REPLACE
-- Given an object that is being restored that already exists
-- on the target, this option will cause the restore operation
-- (1) to unfreeze the target object if it is frozen.
-- (2) If the target object is an installed or coded Ada unit
-- with clients, it is demoted to source using Compilation.
-- Demote with the "<ALL_WORLDS>" parameter.
-- Any frozen dependents will be unfrozen.
-- (3) if the parent library into which an object is being
-- restored is frozen, the parent will be unfrozen to restore
-- the object then refrozen.
-- PROMOTE
-- After they are restored, any Ada units will be promoted to the
-- state they were in when they were archived.
-- REMAKE [=NO_MAINS]
-- Like the promote option with the further effect that
-- any objects outside the restore set which were demoted
-- because the replace option was given will be repromoted.
-- If no_mains is specified dependent main programs will not
-- be recoded.
-- GOAL_STATE = ARCHIVED | SOURCE | INSTALLED | CODED
-- Specify that all ada objects restored should (if possible)
-- end up in the given state.
-- EFFORT_ONLY
-- Show what would be restored if restore is run with this
-- set of parameters.
-- CODE [=load_proc_list>]
-- Specifies that just the Code Archive Object for the named
-- load_procs are to be restored. This option is needed only when
-- it is desired to restore a Code Archive Object from an archive
-- that also contains the spec for that load_proc, which is not
-- to be restored.
-- COMPATIBILITY_DATABASE, (CDB) [=<Subsystems>]
-- Specifies that the Compatibility Databases for just the named
-- subsystems are to be restored.
-- IGNORE_CDB
-- Specifies that no compatibility information is to be restored.
-- LINKS [=<worlds>]
-- specifies that just the link packs for the named worlds are to
-- be restored. if no argument is given all link packs of all worlds
-- on the tape are restored.
-- PRIMARY
-- restore the compatibility database as a primary, rather than as a
-- secondary (which is the default).
-- REVERT_CDB
-- allow the compatibility database to be overwritten by the values
-- in the restore.
-- OBJECT_ACL=<acl_value>
-- WORLD_ACL=<acl_value>
-- DEFAULT_ACL=<acl_value>
-- Specifies the Access Control List for restored objects
-- (OBJECT_ACL) and worlds (WORLD_ACL) and the default ACL for
-- restored worlds (DEFAULT_ACL).
-- The value is either an ACL specification or one of the special
-- values RETAIN, ARCHIVED, INHERIT.
-- - RETAIN means to set the final acl of an already existing object
-- to the value it had before the restore. If the object doesn't
-- exist the archived acl value will be used. This is the default.
-- - ARCHIVED means to use the ACL archived with the object.
-- - INHERIT means to use the standard inheritence rules for new
-- versions of objects.
-- BECOME_OWNER
-- Modify the ACL of all restored objects such that the restorer
-- becomes the owner of the restored object.
-- TRAILING_BLANKS=integer
-- Specifies the number of trailing blanks which are to be
-- considered significant when parsing ada units during the
-- restore. If a line ends in more than this number of blanks,
-- the line break will be preserved in the image of the restored
-- ada unit. The default is 2.
-- UNCONTROL
-- specifies that controlled objects which are checked in
-- will be made uncontrolled before being overwritten.
-- objects will be recontrolled at the end of the archive.
-- only valid if the replace option is also given.
-- REQUIRE_PARENTS
-- require that the parent context for a unit to be restored
-- already exists. default is false.
-- VOLUME
-- specifies which volume archive is to create worlds on.
-- VERBOSE
-- Specifies that extra log messages are to be generated describing
-- more fully the steps of the restore process.
-- UNLOAD
-- A boolean option. When True (the default), causes the tape to
-- be rewound and unloaded after the operation is complete. When
-- False, this option causes the tape to be rewound to the beginning
-- and to remain online and available for subsequent requests.
-- When the tape is left online, subsequent requests send a tape-
-- mount request to the operator's console, which must be answered
-- before the tape can be accessed.
---------------------------------------------------------------------------
procedure List (Objects : String := "?";
Options : String := "R1000";
Device : String := "MACHINE.DEVICES.TAPE_0";
Response : String := "<PROFILE>");
-- Produce a listing of the names of the objects on an Archive tape.
-- The Objects parameter specifies the objects to be listed. Wildcards
-- are permitted, so if Objects = "?", the default, then all Objects are
-- listed.
-- The Options parameters are:
-- FORMAT and LABEL
-- as in the Save options.
-- NONRECURSIVE
-- don't list items on tape which are subcomponents of objects
-- selected by first paramater.
---------------------------------------------------------------------------
procedure Copy (Objects : String := "<IMAGE>";
Use_Prefix : String := "*";
For_Prefix : String := "*";
Options : String := "";
Response : String := "<PROFILE>");
-- Copy objects from one location to another, including between
-- machines on the same network.
-- The Objects parameter specifies where the objects are to be gotten
-- from as in an Archive.Save.
-- The Objects and Use_prefix parameters consist of an (optional)
-- machine name followed directly by an objects name.
-- A machine name has the form !!name.
-- Example:
-- !!machine1!users.foo
-- Another acceptable way to say the same thing is !!machine1.users.foo
--
-- The machine name on the objects parameter specifies the source machine.
-- The machine name on the use prefix specifies the destination machine.
-- If either machine is the one on which the command is being given
-- it is not necessary to give the machine name.
-- The non-machine name part of the Objects parameter is a name like that
-- given to the save operation.
--
-- The Use_Prefix/For_Prefix parameters specify where the objects
-- are to go as in Archive.Restore.
-- If the Use_Prefix parameter is "*" or just a machine name, then the
-- source Objects are moved to the same place on the destination machine
-- as specified by the source. The For_Prefix parameter is ignored.
-- If neither Objects nor Use_Prefix have a machine name then the
-- objects are copied from the source to the Use_Prefix on the
-- current machine.
--
-- If it is desired to transfer the same set of objects to multiple
-- targets in the same command a set of target names can be
-- specified as the use_prefix in one of the following two ways.
-- The use prefix can be of the form:
-- [use_prefix1, ..., use_prefixn]<optional_naming_expression>
-- examples:
-- archive.copy (..., use_prefix => "[m1,m2]", ...);
-- archive.copy (..., use_prefix => "[m1,m2,m3]!users.foo", ...);
--
-- The use prefix can be of the form:
-- _filename<optional_naming_expression_beginning_with_!>
-- The filename should contain a list of use_prefix's, one per line.
-- examples:
-- archive.copy (... use_prefix => "_targets", ...);
-- archive.copy (... use_prefix => "_targets!users.foo", ...);
-- where targets is a text file containing (e.g)
-- m1
-- m2
--
-- In both of the above cases the leading !! in machine names is optional.
---------------------------------------------------------------------------
-- The Options parameter has the following options.
--
-- AFTER, CODE, CDB, LINKS, IGNORE_CDB
-- NONRECURSIVE, EFFORT_ONLY
-- as in the save operation.
--
-- ALL_OBJECTS, NEW_OBJECTS, UPDATED_OBJECTS, CHANGED_OBJECTS,
-- EXISTING_OBJECTS, DIFFERENT_OBJECTS
-- PROMOTE, REPLACE, UNCONTROL, REMAKE, GOAL_STATE,
-- PRIMARY, REVERT_CDB, REQUIRE_PARENTS, VOLUME
-- BECOME_OWNER, OBJECT_ACL, WORLD_ACL, DEFAULT_ACL
-- VERBOSE
-- as in the restore operation.
-- ENABLE_PRIVILEGES
-- cause the archive server (and the copy job) to attempt to
-- enable_privileges.
---------------------------------------------------------------------------
-- Examples of calls:
--
-- Copy (Objects => "!USERS.JMK.CLI",
-- Use_Prefix => "!!M1");
--
-- will copy the CLI directory in !USERS.JMK on the
-- current machine to machine M1 !USERS.JMK.CLI.
--
-- Copy (Objects => "!!M2!USERS.OLLIE.CLI");
--
-- will copy !USERS.OLLIE.CLI on M2 to !USERS.OLLIE.CLI on the
-- current machine.
--
-- Copy (Objects => "!!M3!USERS.JMK.CLI.CMD",
-- Use_Prefix => "!USERS.OLLIE",
-- For_Prefix => "!USERS.JMK.CLI");
--
-- will copy the file !USERS.JMK.CLI.CMD on M3 to
-- !USERS.OLLIE.CMD on the current machine.
-- note when repositioning Objects it is necessary to give a
-- for_prefix which is a prefix of the Objects part of the
-- source parameter.
--
-- Copy (Objects => "!!M1!USERS.JMK.ILFORD",
-- Use_Prefix => "!!M2!AGFA",
-- For_Prefix => "!USERS.JMK");
--
-- will copy !USERS.JMK.ILFORD from machine M1 to
-- machine M2 !AGFA!ILFORD
--
-- Copy (Objects => "!USERS.JMK.CLI",
-- Use_Prefix => "!!M1",
-- Options => "REPLACE AFTER=12/25/86");
--
-- will copy those files which have changed since 12/25/86 in
-- !USERS.JMK.CLI on the current machine to machine M1 !USERS.JMK.CLI
-- Any existing files with the same names will be overwritten.
---------------------------------------------------------------------------
procedure Server;
-- start the archive server;
procedure Status (For_Job : Machine.Job_Id);
-- Prints information about the status of the Archive job specified.
-- Can be the job number of an Archive Server or of a job running
-- Archive.Copy, Archive.Restore, or Archive.Save.
pragma Subsystem (Archive);
pragma Module_Name (4, 3546);
end Archive;with Compilation;
with System_Utilities;
package Cmvc is
-- All CMVC commands raise Profile.Error if any error is detected
-- and Profile.Propagate or Profile.Raise_Error is true
------------------------------------------------------------------------
-- Some of the following reservation commands take the name of an object
-- that appears in more than one view. The naming expression
-- !mumble.subsystem.[view1, view2, view3].units.object
-- is useful for such times.
procedure Check_Out (What_Object : String := "<CURSOR>";
Comments : String := "";
Allow_Implicit_Accept_Changes : Boolean := True;
Allow_Demotion : Boolean := False;
Remake_Demoted_Units : Boolean := True;
Goal : Compilation.Unit_State := Compilation.Coded;
Expected_Check_In_Time : String := "<TOMORROW>";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- Check out reserves one or more objects (specified by What_Object) so
-- that they may be modified in only one view. All of the
-- objects specified must belong to the same working view.
-- An object must be 'controlled' to be reserved (see Make_Controlled),
-- a warning is issued for objects that are not controlled.
-- The reservation spans all of the views that share the
-- same reservation token for the element.
-- This command implicitly accepts changes in the checked out object,
-- updating the value of the object to correspond to the most
-- recent generation of that element/reservation token pair.
-- Demotions caused by the implicit accept_changes may be remade to the
-- goal specified.
-- The Comments field is stored with the notes for the object.
-- If What_Object is a set, the comment is stored with all of them.
-- Expected_Check_In accepts any string that Time_Utilities.Value
-- will accept.
procedure Check_In (What_Object : String := "<CURSOR>";
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- Release the reservation on the object. What_Object may
-- specify a set of objects. This command only applies to
-- the controlled objects in the set and will note any
-- objects that are not controlled.
-- Comments are treated as in Check_Out
procedure Accept_Changes
(Destination : String := "<CURSOR>";
Source : String := "<LATEST>";
Allow_Demotion : Boolean := False;
Remake_Demoted_Units : Boolean := True;
Goal : Compilation.Unit_State := Compilation.Coded;
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- This operation updates the Destination to reflect changes
-- (objects that have been checked in) specified by Source.
-- Demoted units may be repromoted to the specified goal.
-- The Destination is either a view or a set of objects (all in
-- one view). Specifying the view is equivalent to specifying
-- all the objects in the view. Uncontrolled objects in the
-- destination are ignored except that a note is issued.
-- The Source is either "<LATEST>", a view, a configuration,
-- or a set of objects all in one view.
-- If the Source is "<LATEST>", the destination objects
-- will be updated to the most recently checked in version.
-- If the most recent generation of a source object is currently
-- checked out, the previous generation is used and a warning
-- is issued.
-- If the Source is a view and the Destination is a view, this command
-- is basically "Make the Destination view look exactly like the
-- Source view". Every controlled object in the source is copied
-- to the destination and the configuration in the destination
-- is updated. This includes new objects which did not previously
-- exist in the destination. If the destination has a more recent
-- version than the source, the destination will not be updated and
-- a warning is issued. In particular, if objects are checked out in
-- the destination, they will not be changed.
-- If objects are checked out in the source this operation
-- will use the previously checked in version of the object and
-- a warning will be issued.
-- If the Source is a view and the Destination is a set of objects,
-- the destination objects are updated to the corresponding objects
-- in the source view, as above.
-- If the source is a configuration it is identical to having the
-- source be a view except that the configuration specifies the
-- versions to use and they may be older (less up to date) than
-- the ones in the destination. Thus if the source is a configuration
-- then destination objects may "go backwards", while this will not
-- happen if the source is a view.
-- If the source is a set of objects and the destination is a view,
-- the corresponding objects in the destination view are updated
-- to the source objects.
-- A common way of using Accept_Changes is to use the default parameters
-- during normal development to accept changes made in other subpaths.
-- Then periodically an integration view (in the path) is updated by
-- first accepting all relevant subpaths into the integration view
-- (accept_changes (destination => integration_view, source =>
-- active_subpath_working_view)).
-- Then this integration view is compiled (and tested). The subpaths are
-- then re-synchronized by accepting the integration view (source =>
-- integration_view, destination => destination_subpath_working_view).
-- In addition to synchronizing the source, this protocol updates
-- the libraries in such a way the relocation operates most effectively,
-- preventing compilation in many cases when changes move between views.
procedure Abandon_Reservation
(What_Object : String := "<SELECTION>";
Allow_Demotion : Boolean := False;
Remake_Demoted_Units : Boolean := True;
Goal : Compilation.Unit_State := Compilation.Coded;
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- Forget about a check_out of some object, or set of objects.
-- This reverts the objects back to last checked in version.
-- This operation is an "undo" for Check_Out, except that it
-- does not undo the implict Accept_Changes that goes with
-- a Check_Out. Demoted units may be repromoted to the specified goal.
procedure Revert (What_Object : String := "<SELECTION>";
To_Generation : Integer := -1;
Make_Latest_Generation : Boolean := False;
Allow_Demotion : Boolean := False;
Remake_Demoted_Units : Boolean := True;
Goal : Compilation.Unit_State := Compilation.Coded;
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- Replace the contents of the specified object with the contents
-- of the specified generation. The operation is equivalent to an
-- Accept_Changes from a configuration containing the specified
-- generation.
-- If Make_Latest_Generation is true, then the operation is equivalent to
-- a Check_Out, a copy of the specified generation into the object, and
-- a Check_In.
-- Generation of -n means n generations back; thus -1 => the previous
-- generation.
------------------------------------------------------------------------
-- The following commands allow the creation and interogation of
-- a note scratchpad for each element. Descriptive information
-- regarding what is being changed, why, or whatever, can be put
-- into the scratchpad.
-- The notes for each element can also be manipulated through the
-- cmvc object editor (see cmvc.notes below). In most instances
-- this interface will prove easier to use (for example, the
-- object need not be checked out to manipulate the notes).
procedure Get_Notes (To_File : String := "<WINDOW>";
What_Object : String := "<CURSOR>";
Response : String := "<PROFILE>");
-- Copy the notes from the object. If To_File is the default, then
-- a new I/O window is created and the notes are copied into this window.
-- The first line of this window is the name of the object, which is
-- used by Put_ and Append_Notes to put the notes back. The notes
-- displayed are those that go with the generation of the object pointed
-- at. See Cmvc_History for ways of getting notes and other information
-- on a range of generations
-- The next three commands require the object in question to be
-- checked out.
procedure Put_Notes (From_File : String := "<WINDOW>";
What_Object : String := "<CURSOR>";
Response : String := "<PROFILE>");
-- Replace the notes for the specified object. If the I/O window
-- was created by Get_Notes, the window (first line) contains the name
-- of the object to write back into, and What_Object is ignored.
procedure Append_Notes (Note : String := "<WINDOW>";
What_Object : String := "<CURSOR>";
Response : String := "<PROFILE>");
-- Append the specified text to the notes. If Note is <WINDOW>,
-- the associated window must have been created by Get_Notes or
-- Create_Empty_Note_Window; in this case What_Object is ignored.
-- If note is a string, then that string is appended to the object
-- selected by What_Object. If the content of Note is prepended with a
-- '_', Note is interpreted as a text file name, and the content of
-- that file is appended to the selected object.
procedure Create_Empty_Note_Window (What_Object : String := "<CURSOR>";
Response : String := "<PROFILE>");
-- Create an empty window (with no underlying directory object)
-- to be used for constructing notes for the specified object.
-- Typically, Append_Notes is used to actually add the text
-- to the object's notes.
------------------------------------------------------------------------
procedure Make_Controlled
(What_Object : String := "<CURSOR>";
Reservation_Token_Name : String := "<AUTO_GENERATE>";
Join_With_View : String := "<NONE>";
Save_Source : Boolean := True;
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- Make the object or objects specified by What_Object be subject to
-- reservation. The objects must be in a working view and not
-- already controlled. All objects must be in the same subsystem.
-- If Join_With_View is specified, the objects are joined with the
-- object in that view, using the reservation token specified by that view.
-- If no view is specified, the reservation token name is used if provided,
-- else the development path name of the view containing the object is
-- used to compute a new reservation token name.
-- The value of save_source is meaningful only the first time an
-- object with a particular name is controlled. When the first object
-- with the name is controlled, save_source specifies whether or
-- not source will be saved in the CMVC database for all objects
-- with the same name. When an object with the name has already
-- been controlled, the value of save_source must agree with the
-- value that was set for the first such object.
-- Note that setting save_source to false is the only way to control
-- files that do not have textual representation.
-- Also note that when save_source is false the following operations
-- behave differently:
-- 1. Abandon_Reservation will not revert the object to its previous
-- state.
-- 2. Check_Out will not cause the object to be updated to the latest
-- checked in value, unless that value exists in the directory system.
-- 3. Accept_Changes will update the object only if the last checked in
-- object exists in the directory system.
-- 4. Make_Controlled will not check that the new object being controlled
-- is equivalent to the last checked in value.
procedure Make_Uncontrolled (What_Object : String := "<CURSOR>";
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- Make an object or objects uncontrolled.
-- This means the objects are no longer subject to reservation
-- (in the enclosing view).
procedure Sever (What_Object : String := "<SELECTION>";
New_Reservation_Token_Name : String := "<AUTO_GENERATE>";
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- Make the object or objects in the given working view have a separate
-- reservation. If multiple objects are specified, all objects must be
-- in the same view.
-- A specific reservation token name can be provided or a new token
-- name will be generated. Providing a token name is not allowed
-- to cause implicit joining to other views.
procedure Join (What_Object : String := "<SELECTION>";
To_Which_View : String := ">>VIEW NAME<<";
Reservation_Token_Name : String := "";
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- Make object in two or more working views share a reservation. The
-- objects may either be joined to a specific view or token (but only
-- one may be specified). The objects being joined must be identical
-- to the last checked_in version in each joined set.
------------------------------------------------------------------------
procedure Merge_Changes (Destination_Object : String := "<SELECTION>";
Source_View : String := ">>VIEW_NAME<<";
Report_File : String := "";
Fail_If_Conflicts_Found : Boolean := False;
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- Merge two versions of the same object together, leaving the result
-- in destination object. In order for this command to succeed, the
-- Source_View and the view containing the Destination_Object must
-- have been copied from some common view sometime in the past, and
-- the configuration for that view must still exist.
-- Destination_Object must refer to the last generation; all changes must
-- have been accepted.
-- The command writes a report showing what it did, as well as changing
-- the destination object. If the report_file name is "", the report
-- is written to Get_Simple_Name (Destination_Object) & "_Merging_Report".
-- Conflicts are defined to be regions of change in the source and
-- destination that directly overlap, ie the same line(s) have been
-- changed in both objects. If Fail_If_Conflicts_Found is true,
-- no updating is done, but the report file is left.
-- If it is desired to rejoin the two objects after the merge, then
-- check out the Merge source object, copy the Merge Destination_Object
-- into the source, then Join the objects.
-----------------------------------------------------------------------
function Imported_Views (Of_View : String := "<CURSOR>";
Include_Import_Closure : Boolean := False;
Include_Importer : Boolean := False;
Response : String := "<WARN>") return String;
-- return a string suitable for name resolution that names the union of
-- all of the imports specified by the view(s) Of_View. These views
-- are in no particular order.
------------------------------------------------------------------------
-- IMPORTS --
------------------------------------------------------------------------
-- CMVC supports selective importing of units when views are imported.
-- This is accomplished using Imports_Restrictions and
-- Exports_Restrictions.
--
-- Exports_Restrictions are subsets of exported Ada units controlled
-- by the exporting view (spec view). The subset is determined by the
-- contents of a text file in the Exports directory of the view. This
-- file contains Naming expressions which, when resolved against the
-- Units directory, produce a list of objects that are exported by
-- that subset.
-- Imports_Restrictions are further restrictions on what Ada units are
-- to be imported. The restriction specifies which export restriction
-- to use (if any), a list of Ada units (using simple names) to
-- exclude, and a list of units to rename. A restriction is a text
-- file, in the Imports directory, with the same name as the subsystem
-- containing the view being imported. The name of restriction
-- may either be the simple name of the imported subsystem or the
-- full name of the subsystem. If the full name is used, the file
-- name is formed by taking the path name, removing the leading "!" and
-- changing all periods to underscores. If both forms are found
-- in the same directory, then the full name form takes precedence.
-- Each line of the file specifies one thing. The form of the lines are:
--
-- EXPORT_RESTRICTION=>restriction_name
-- Specify the name of the export restriction. No blanks are
-- allowed. If more than one restriction is specified, the
-- union of all of the restictions is used.
-- Object_Name Link_Name
-- Import Object_Name but make a link with Link_Name (a rename)
-- ~Object_Name
-- Dont import Object_Name
-- Object_name
-- Import Object_Name and use Object_Name for the link name
-- @
-- Import all Objects, except those removed above
-- In all cases, the names provided above are simple names, ie no '.'s
-- in them.
------------------------------------------------------------------------
-- SELECTING VIEWS --
------------------------------------------------------------------------
-- In the following commands, wherever a view is called for, a naming set
-- can be used. A text file containing the names of configurations
-- or views can also be used. However, you must use the leading '_'
-- convention supported by Naming. Also, configuration names can be
-- used in place of views anywhere, assuming that the view represented
-- by the configuration still exists.
------------------------------------------------------------------------
-- SPEC VIEWS --
------------------------------------------------------------------------
-- Spec views in CMVC are by default uncontrolled. The reason for this
-- is to allow free changing of specs in the load views, accepting the
-- changes back and forth, then incrementally making the changes in the
-- spec views.
-- It controlling of spec views is desired, use Make_Controlled after
-- creating the views. But be forewarned that checking out a spec
-- where an implicit accept is required will probably obsolesce all
-- of the spec's clients.
------------------------------------------------------------------------
procedure Release (From_Working_View : String := "<CURSOR>";
Release_Name : String := "<AUTO_GENERATE>";
Level : Natural := 0;
Views_To_Import : String := "<INHERIT_IMPORTS>";
Create_Configuration_Only : Boolean := False;
Compile_The_View : Boolean := True;
Goal : Compilation.Unit_State := Compilation.Coded;
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Volume : Natural := 0;
Response : String := "<PROFILE>");
-- Create a new release view in the subsystem. If Release_Name is
-- "<AUTO_GENERATE>", the view will have the same name prefix as the
-- working view, with _n_m appended as appropriate given the level.
-- Otherwise Release_Name must be the simeple name of the new release.
-- Since the new view is a release, it is frozen. If From_Working_View
-- names multiple views, each named working view is released as
-- above, and the imports are adjusted so that the new releases
-- reference each other as appropriate instead of the working views.
-- Views_To_Import specifies, perhaps by indirection through an activity,
-- a set of views to be used as imports by the new view(s). This allows
-- changing imports during a release. Imports already adjusted during
-- the releasing of working views will be left alone, otherwise
-- subsystems currently imported will be reimported. In other words,
-- if this were an import command, Only_Change_Imports would be true.
-- If Compile_The_View is true, the compiler is run before the views
-- are frozen, trying to promote the units to the indicated Goal.
-- The views are frozen even if compilation fails.
-- This command creates a configuration object named release_name
-- and a state directory named release_name_state. Both
-- objects are created in SUBSYSTEM.state.configurations.
-- The objects can be used by the build command to reconstruct
-- a view from the released configuration.
-- A controlled text object (state.release_history) is used by this
-- command. Release enters the comments supplied with the command
-- into the notes for this object. Feel free to check out and modify
-- this object to further describe what is going on. This object is joined
-- across all of the releases and the working view of a subpath.
-- Furthermore, the object is checked out and in by the release command
-- in order to mark the time of the release.
------------------------------------------------------------------------
procedure Copy (From_View : String := "<CURSOR>";
New_Working_View : String := ">>SUB/PATH NAME<<";
View_To_Modify : String := "";
View_To_Import : String := "<INHERIT_IMPORTS>";
Only_Change_Imports : Boolean := True;
Join_Views : Boolean := True;
Reservation_Token_Name : String := "<AUTO_GENERATE>";
Construct_Subpath_Name : Boolean := False;
Create_Spec_View : Boolean := False;
Create_Load_View : Boolean := False;
Create_Combined_View : Boolean := False;
Level_For_Spec_View : Natural := 0;
Model : String := "<INHERIT_MODEL>";
Remake_Demoted_Units : Boolean := True;
Goal : Compilation.Unit_State := Compilation.Coded;
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Volume : Natural := 0;
Response : String := "<PROFILE>");
-- Create a new working view. Working views are named Mumble_Working,
-- where mumble is supplied as New_Working_View. If Join_Views is
-- true, the two views share reservations of the all of the controlled
-- objects in the two views. If false, reservations aren't shared
-- across the views for any objects. If From_View names multiple views, a
-- copy is made for each of those views and, if the originals
-- import each other (computed using the subsystem, not the view),
-- the copies will (try) to import the new views of those subsystems.
-- If Join_Views is false, new reservation tokens are created for all
-- of the controlled objects. The default is to use the name supplied
-- as the >>SUBPATH_NAME<<.
-- View_To_Import supplies a set of views to be processed according to
-- the value of Only_Change_Imports. If Only_Change_Imports is true,
-- a copied view always inherits the source view's imports. After the
-- copy, the imports specified by View_To_Import are applied against the
-- new view, replacing any inherited import if needed.
-- If Only_Change_Imports is false, then either the imports are inherited
-- from the source, or the complete set of imports specified by
-- by View_To_Import is imported into the copy.
-- View_To_Modify specifies the set of working views that are to have
-- their imports changed to refer to the new copy(s). The
-- View_To_Modify views are also changed to refer to the views specified
-- by View_To_Import. For this import operation, Only_Change_Imports
-- is forced to true.
-- Construct_Subpath_Name cause Copy to contruct the target view name
-- by appending New_Working_View to the prefix of the source view name
-- up to the first '_' (See paths and subpaths below).
-- Remake demoted units, if true, indicates that ada units that were
-- demoted during the copy process are to be recompiled. They are
-- compiled to the level indicated by Goal.
-- Goal further indicates the desired state of all of the units after
-- copy. No unit will be in a state higher than specified by goal, but
-- might be in a lower state. For example, a source unit that is copied
-- will remain source, regardless of Goal, but a Coded unit will be
-- demoted if Goal is installed or less.
-- The order of the copy and import operations is:
--
-- 1. Create the new view.
-- 2. If Inherit_Imports, bring along the old imports
-- 3. Import the new views into the new views, forcing
-- Only_Change_Imports => True
-- 4. If not Inherit_Imports, import the specified views
-- into the new views.
-- 5. Import the new views + View_To_Import into Views_To_Modify,
-- forcing Only_Change_Imports => true
-- Spec views are created by copying the units if the source is a load
-- view, otherwise using Relocation. Spec views are created with all
-- objects uncontrolled. If level_for_spec_view = natural'last, the
-- spec view is given the name supplied as new_working_view, otherwise
-- a name is generated as 'New_Working_View & Release_Numbers & "_spec"'
-- In a spec_load subsystem, combined views can be created by setting
-- the create_combined_view parameter. Combined views are useful in
-- spec_load subsystems when spec and load views are compiled for the
-- R1000 target and combined views must be compiled for a different
-- target that does not support subsystem look-through.
-- Note that if create_spec_view, create_load_view, and create_combined_view
-- are all false, then the new view has the same type as from_view.
-- It is an error to set more that one of these parameters to be true.
-- It is recognized that this is a complicated command. Using the
-- procedures below (which are effectively renames) might make more
-- sense if the methodolody in use permits it (Path, Subpath, etc).
------------------------------------------------------------------------
-- PATHS AND SUBPATHS --
------------------------------------------------------------------------
-- The following procedures support the notion of paths and subpaths.
-- A Path is a logically connected series of releases in which all
-- controlled objects are joined together. In other words, there is
-- no branching within a path. A Subpath is an extension of the
-- path, allowing multiple developers to make changes and test
-- without getting in each others way. However, controlled objects
-- in the subpaths are joined with the path; people in two subpaths
-- cannot independently change the same object. In addition, a path
-- and its subpaths share the same model, which means they share
-- the same Target_Key and initial links.
-- In Delta, paths and subpaths are identified by string name conventions.
-- The name of the path is the view name up to the first '_'. The
-- subpath extension is the name from this '_' to the '_Working'. Thus
-- Rev9_Cbh_Working has a path name of Rev9 and subpath extension of
-- Cbh.
-- Multiple paths are used when multiple targets are involved, or when
-- objects are to be changed independently. For example, assume that
-- a version of a product has been shipped, and is in maintenance, and
-- that development is progessing on a new version. It is likely that
-- the old and new versions would be separate paths, since the objects
-- would have to be independently changed (these paths would not be
-- 'joined').
-- In the multiple target case, the paths might be created joined.
-- Using the above scenario, assume that the release that has been shipped
-- works on two targets, but most or all of the code is target
-- independent. Then the two paths, one for each target, would be
-- created joined together, then have the objects that are not common
-- 'Sever'ed.
procedure Make_Path (From_Path : String := "<CURSOR>";
New_Path_Name : String := ">>PATH NAME<<";
View_To_Modify : String := "";
View_To_Import : String := "<INHERIT_IMPORTS>";
Only_Change_Imports : Boolean := True;
Create_Load_View : Boolean := False;
Create_Combined_View : Boolean := False;
Model : String := "<INHERIT_MODEL>";
Join_Paths : Boolean := True;
Remake_Demoted_Units : Boolean := True;
Goal : Compilation.Unit_State := Compilation.Coded;
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Volume : Natural := 0;
Response : String := "<PROFILE>");
procedure Make_Subpath (From_Path : String := "<CURSOR>";
New_Subpath_Extension : String := ">>SUBPATH<<";
View_To_Modify : String := "";
View_To_Import : String := "<INHERIT_IMPORTS>";
Only_Change_Imports : Boolean := True;
Remake_Demoted_Units : Boolean := True;
Goal : Compilation.Unit_State := Compilation.Coded;
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Volume : Natural := 0;
Response : String := "<PROFILE>");
-- The Subpath_Extension is appended to the path name of the source
-- view (From_Path). From_Path can actually name the path or any
-- subpath of the path. The '_' between the path and subpath extension
-- is automatically provided.
procedure Make_Spec_View
(From_Path : String := "<CURSOR>";
Spec_View_Prefix : String := ">>PREFIX<<";
Level : Natural := 1;
View_To_Modify : String := "";
View_To_Import : String := "<INHERIT_IMPORTS>";
Only_Change_Imports : Boolean := True;
Remake_Demoted_Units : Boolean := True;
Goal : Compilation.Unit_State := Compilation.Coded;
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Volume : Natural := 0;
Response : String := "<PROFILE>");
-- Make a spec view for a path. Spec_View_Prefix is the string that
-- replaces the path and subpath name. For example, if creating a
-- spec view from a subpath named rev9_cbh_working, with
-- Spec_View_Prefix => Env9, the result will be Env9_n_Spec, assuming
-- level => 0 and two levels are specified by the model. N is a
-- number automatically generated from the current release number for
-- the path/subpath. If level = natural'last, the name supplied as
-- Spec_View_Prefix is used for the name of the view, with no suffixes
----------------------------------------------------------------------
procedure Import (View_To_Import : String := "<REGION>";
Into_View : String := "<CURSOR>";
Only_Change_Imports : Boolean := False;
Import_Closure : Boolean := False;
Remake_Demoted_Units : Boolean := True;
Goal : Compilation.Unit_State := Compilation.Coded;
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- Imports spec or combined views as appropriate into the specified
-- view(s). The import specification can be a set of view names,
-- in which case all views are imported, unless only_change_imports is
-- true. In this case only subsystems that were imported sometime in
-- the past are reimported. All others are ignored.
-- If View_To_Import is "", then the imports of Into_View are refreshed.
-- This means the various imported views are examined, and any new
-- Ada specs are imported in to the current view.
-- It is useful to invoke Import with Views_To_Import = Into_View and
-- Only_Change_Imports is true. This will cause a set of views to be
-- changed to import each other.
procedure Remove_Import (View : String := ">>VIEW NAME<<";
From_View : String := "<CURSOR>";
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- remove references to a previously imported view.
procedure Remove_Unused_Imports (From_View : String := "<CURSOR>";
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- Search through all of the Ada units in the view and examine the
-- withs. If no units in some imported view are referenced, remove
-- that import.
-- This command generates warnings if units in spec or combined
-- views are referenced, but the view isn't imported. Errors are
-- generated if units in load views are referenced.
procedure Replace_Model (New_Model : String := ">>NEW MODEL NAME<<";
In_View : String := "<CURSOR>";
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- Replace the model with the new one. All units must be source.
-- This command gets the switch file from the new model (if one
-- was provided), readjusts the maximum levels (which affects future
-- releases), and rebuilds the links.
------------------------------------------------------------------------
-- SYSTEM OBJECTS --
------------------------------------------------------------------------
type System_Object_Enum is (Spec_Load_Subsystem,
Combined_Subsystem, System);
-- System objects may be either subsystems or systems. A subsystem
-- may be either a spec_load_subsystem or a combined_subsystem.
-- The type of subsystem controls the kinds of views which
-- the system object may contain. The subsystem type also controls
-- whether importing into the subsystem must be hierarchical or
-- may be non-hierarchical.
-- Spec_Load subsystems may contain spec views, load views, or
-- combined views. All views in spec_load subsystems are
-- restricted to have only hierarchical imports. A views imports
-- are hierarchical if the import closure of the view does not
-- contain itself.
-- Combined subsystems may only contain combined views. The views
-- in a combined subsystem need not have hierarchical imports.
-- A view in a combined subsystem may include itself in its
-- import closure.
-- Systems contain system views. Systems are used by Cmvc_Hierarchy
-- to coordinate the construction of multi-subsystem systems.
procedure Initial (System_Object : String := ">>SYSTEM OBJECT NAME<<";
Working_View_Base_Name : String := "Rev1";
System_Object_Type : System_Object_Enum :=
Cmvc.Spec_Load_Subsystem;
View_To_Import : String := "";
Create_Load_View : Boolean := True;
Model : String := "R1000";
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Volume : Natural := 0;
Response : String := "<PROFILE>");
-- Build a new system object of the specified type. Also create a working
-- view and import as specified. This command can be used to create
-- an empty view in an existing system object. If the system object type
-- is spec_load_subsystem the new view will be either a load view or a
-- combined view depending on the value of create_load_view.
-- While creating the new view directory structure in the model world
-- will be duplicated in the new view.
------------------------------------------------------------------------
procedure Information (For_View : String := "<CURSOR>";
Show_Model : Boolean := True;
Show_Whether_Frozen : Boolean := True;
Show_View_Kind : Boolean := True;
Show_Creation_Time : Boolean := True;
Show_Imports : Boolean := True;
Show_Referencers : Boolean := True;
Show_Unit_Summary : Boolean := True;
Show_Controlled_Objects : Boolean := False;
Show_Last_Release_Numbers : Boolean := False;
Show_Path_Name : Boolean := False;
Show_Subpath_Name : Boolean := False;
Show_Switches : Boolean := False;
Show_Exported_Units : Boolean := False;
Response : String := "<PROFILE>");
-- Show various things about a view. Please see Cmvc_History for
-- ways of extracting other information about the controlled objects
-- in the view.
------------------------------------------------------------------------
procedure Destroy_View (What_View : String := "<SELECTION>";
Demote_Clients : Boolean := False;
Destroy_Configuration_Also : Boolean := False;
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- Destroy a view. If Demote_Clients is false, the view can have no
-- referencing views (clients); if it does, the destroy fails. If
-- Demote_Clients is true, the view is "remove_import"ed from those
-- clients (which might cause lots of obsolescence), then the view is
-- destroyed. The configuration object for the view is left behind
-- in its normal place (see Release, above) so the view can be
-- reconstructed using "Build"
procedure Destroy_Subsystem (What_Subsystem : String := "<SELECTION>";
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- Destroy a subsystem. There must be no views in the subsystem.
procedure Destroy_System (What_System : String := "<SELECTION>";
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- Destroy a system. There must be no views in the system.
------------------------------------------------------------------------
procedure Build (Configuration : String := ">>CONFIGURATION NAME<<";
View_To_Import : String := "<INHERIT_IMPORTS>";
Model : String := "<INHERIT_MODEL>";
Goal : Compilation.Unit_State := Compilation.Installed;
Limit : String := "<WORLDS>";
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Volume : Natural := 0;
Response : String := "<PROFILE>");
-- Rebuild a view from history. If Configuration_Object_Name refers to
-- a text file, that file is assumed to contain a list of configuration
-- object names to be built.
-- If View_To_Import = "<INHERIT_IMPORTS>", and if a directory with
-- the name "same as configuration_object" & "_STATE" exists, that
-- directory contains state that is used to rebuild the imports.
-- Note, that the state directory is created by the release command
-- when a configuration-only release is created.
---------------------------------------------------------------------
-- HISTORY COMMANDS --
---------------------------------------------------------------------
-- The following commands display history information, in various
-- formats, of Cmvc controlled objects
procedure Show_History (For_Objects : String := "<CURSOR>";
Display_Change_Regions : Boolean := True;
Starting_Generation : String := "<CURSOR>";
Ending_Generation : String := "";
Response : String := "<PROFILE>");
-- Display the history for the specified objects. If a view is
-- specified, all of the controlled objects in that view are displayed.
-- This history includes notes, checked_out and _in information, and
-- optionally the actual changes
-- If display_change_regions is true, the differences between a
-- generation and the previous one (n-1, n) are displayed. The display
-- is in the form of regions where changes occurred similar to that
-- produced by File_Utilities.Difference(Compressed_Output=>True)
-- The first generation to display is determined by looking up
-- the object in the view(s) specified by Starting_Generation. If
-- Starting_Generation = "", the display starts at generation 1.
-- The last generation to display is determined by Ending_Generation.
-- If E.._G.. is "", the last displayed is the latest one. If E.._G..
-- is the name of a view, the generation specified by that view is
-- used as the last.
procedure Show_History_By_Generation
(For_Objects : String := "<CURSOR>";
Display_Change_Regions : Boolean := True;
Starting_Generation : Natural := 1;
Ending_Generation : Natural := Natural'Last;
Response : String := "<PROFILE>");
-- A form of show_history_by_generation that takes explicit
-- generation numbers.
procedure Show_Image_Of_Generation (Object : String := "<CURSOR>";
Generation : Integer := -1;
Output_Goes_To : String := "<WINDOW>";
Response : String := "<PROFILE>");
-- Reconstruct an image of some generation of the specified object.
-- The default (-1) indicates back up one generation from that of
-- Object. Negative numbers are relative to the generation of Object,
-- positive numbers are actual generation numbers.
-- The result is written to current output unless a file name is
-- supplied in Output_Goes_To.
----------------------------------------------------------------------
-- The following commands produce a report showing objects that
-- meet some criteria. This report shows the following information
-- about each object.
-- Object Name Generation Where Chkd Out By Who Expected Check In Source Saved
-- =========== ========== ===== ======== ====== ================= ============
-- UNITS.FOO 5 of 8 VIEW Yes MTD Apr 7, 1987 Yes
-- Object name is the element name (the name from the view down)
-- Generation is a pair. The first number is the generation of
-- the object used to lookup the element. The second number is
-- the highest generation produced.
-- Where is either the view containing a copy of the last generation
-- if the object is not checked out, or the view in which the object
-- is checked out. In the case where the object is not checked out,
-- it is possible that there is no representative object, in which
-- case this field is blank.
-- Chkd Out is 'Checked Out'. If this is yes, 'By Who' and
-- 'Expected Check In' provide more information.
-- "Source Saved" tells whether or not source is being saved in the
-- cmvc database for this object.
----------------------------------------------------------------------
procedure Show (Objects : String := "<CURSOR>";
Response : String := "<PROFILE>");
-- Produce the information desribed above for the listed objects.
-- Also produces a report for each object showing which views
-- contain elements sharing a reservation token with the object.
procedure Show_All_Checked_Out (In_View : String := "<CURSOR>";
Response : String := "<PROFILE>");
-- Look through all of the controlled objects in the supplied view, and
-- display information about them if they are checked out anywhere
procedure Show_Checked_Out_In_View (In_View : String := "<CURSOR>";
Response : String := "<PROFILE>");
-- Display information about all of the objects checked out in the
-- view pointed at (or in)
procedure Show_Checked_Out_By_User
(In_View : String := "<CURSOR>";
Who : String := System_Utilities.User_Name;
Response : String := "<PROFILE>");
-- Display information about any object in the view that is checked out
-- be the user given. This command will find the object even if it is
-- checked out in some other view, as long as it is controlled in the
-- view referred to.
procedure Show_Out_Of_Date_Objects (In_View : String := "<CURSOR>";
Response : String := "<PROFILE>");
-- Display information about all objects in the view that are not
-- at the latest revision.
procedure Show_All_Uncontrolled (In_View : String := "<CURSOR>";
Response : String := "<PROFILE>");
-- Show all uncontrolled objects in the designated view.
procedure Show_All_Controlled (In_View : String := "<CURSOR>";
Response : String := "<PROFILE>");
-- Display information about all controlled objects in this view
---------------------------------------------------------------------
-- ARCHIVE COMMANDS --
---------------------------------------------------------------------
procedure Make_Code_View (From_View : String := "<CURSOR>";
Code_View_Name : String := "";
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Volume : Natural := 0;
Response : String := "<PROFILE>");
-- Make a code view with the given name. From_View must only
-- name load views. The result is a load view containing an
-- object called "Code_Database" which contains the executable code for
-- the units in the from_view. There are no ada units in
-- the units directory of the resulting view.
-- This operation fails if any unit isn't coded, or any spec exists
-- for which a body is required and one doesn't exist.
---------------------------------------------------------------------
-- OBJECT EDITOR COMMANDS --
---------------------------------------------------------------------
procedure Edit (View_Or_Config : String := "<CURSOR>";
In_Place : Boolean := False;
Allow_Check_Out : Boolean := True;
Allow_Check_In : Boolean := True;
Allow_Accept_Changes : Boolean := True);
-- Brings up the cmvc object editor on the configuration or the
-- configuration associated with the view. The view parameter may be a
-- view itself or any object within a view.
-- The cmvc object editor display reservation state, object history,
-- and the notes associated with objects.
-- The parameters allow_check_out, allow_check_in, and allow_accept_changes
-- control whether or not these operations can be performed as common
-- commands in the object editor.
procedure Notes (What_Object : String := "<CURSOR>";
In_Place : Boolean := False);
-- Brings up the notes for the generation associated with the
-- specified controlled object. New notes may be appended.
procedure Def (What_Object : String := "<CURSOR>";
In_Place : Boolean := False);
-- Used to go between images in the object editor and
-- objects in the directory system.
-- When applied to an image in the cmvc object editor, tries
-- to find the associated object in the directory system.
-- When applied to a directory object, the cmvc image for that
-- object is produced.
------------------------------------------------------------------------
-- VIEW COMPARISON COMMANDS --
------------------------------------------------------------------------
procedure Compare (Destination : String := "<CURSOR>";
Source : String := "<REGION>";
Compare_Both : Boolean := True;
Show_New_Uncontrolled : Boolean := True;
Show_New_Controlled : Boolean := True;
Show_Uncontrolled : Boolean := True;
Show_Severed : Boolean := True;
Show_Modified : Boolean := True;
Show_Equal : Boolean := False;
Ada_Units : Boolean := True;
Files : Boolean := True;
Response : String := "<PROFILE>");
-- Compare the views. Destination and Source may be each be
-- a view or a configuration. The Ada_Units and Files
-- parameters determine which type of objects are considered in the
-- comparison. The other parameters determine the differences that
-- are displayed and are dependent on the comparison mode.
-- Compare_Both determines whether the views are compared symetrically
-- or whether just the Source is compared against the Destination.
-- When Compare_Both is false the information is useful in determining
-- the effect of Cmvc.Accept_Changes from the Source to the Destination.
--
-- Compare_Both = True
-- Show_New_Uncontrolled - Show any objects that are uncontrolled in one
-- view but do not exist in the other.
-- Show_New_Controlled - Show any objects that are controlled in one
-- view but do not exist in the other.
-- Show_Uncontrolled - Show any objects that are uncontrolled in one view
-- but which do exist in the other view (either
-- controlled or uncontrolled).
-- Show_Severed - Show any objects that exist in both views,
-- but are not joined. This includes objects that
-- are controlled in one and uncontrolled in the other.
-- Show_Modified - Show objects that exist and are joined in both views
-- but are not the same generation.
-- Show_Equal - Show the objects that exist in both views are controlled
-- and joined and have equal generations.
--
-- Compare_Both = False
-- Show_New_Uncontrolled - Show objects in the Source that are uncontrolled
-- and do not exist in the destination.
-- Show_New_Controlled - Show objects in the Source that are controlled
-- and do not exist in the Destination.
-- Show_Uncontrolled - Show objects in the Source that are uncontrolled
-- but do exist in the Destination.
-- Show_Severed - Show objects in the Source view or configuration which
-- also exist in the Destination but are not joined or
-- possibly not controlled.
-- Show_Modified - Show objects in the Source (view or configuration)
-- and in the Destination, which are joined but later
-- in the source in the Destination. This may also
-- include objects checked out in the source.
-- Show_Equal - Show objects in the source view or configuration
-- that also exist with the same generation in the
-- Destination.
--
-- The default parameter settings will display all objects in either
-- view that have different characteristics than the corresponding
-- object in the other view.
procedure Accept_Changes_Effort
(Destination : String := "<CURSOR>";
Source : String := "<REGION>";
Compare_Both : Boolean := False;
Show_New_Uncontrolled : Boolean := False;
Show_New_Controlled : Boolean := True;
Show_Uncontrolled : Boolean := False;
Show_Severed : Boolean := False;
Show_Modified : Boolean := True;
Show_Equal : Boolean := False;
Ada_Units : Boolean := True;
Files : Boolean := True;
Response : String := "<PROFILE>")
renames Compare;
-- The default parameter settings will display the effect of
-- Cmvc.Accept_Changes from the Source into the destination.
pragma Subsystem (Cmvc);
pragma Module_Name (4, 3704);
end Cmvc;package Cmvc_Access_Control is
-- Control over access to objects in views and subsystems,
-- and control over the execution of Cmvc and related commands
-- when they reference specific views or subsystems.
--
-- "Access classes" define the kind of access that a group
-- may have to the objects in a view or subsystem.
--
-- "Execution rights" determine the Cmvc and related commands
-- that a group may execute within a view or subsystem.
-- Each execution right requires some mimimum access to all
-- referenced views and subsystems.
------------------------------------------------------------------------
-- Access Classes --
------------------------------------------------------------------------
type Access_Class is (Reader, Client, Developer, Owner);
-- The kind of access that groups may have to subsystems or views.
-- The access class of a group determines the settings of the
-- ACLs for the objects within the subsystem or view.
-- A group may have only one kind of access at a given time.
-- Higher access classes imply all the rights of lower access classes.
procedure Add_Group (The_Group : String := "NETWORK_PUBLIC";
In_Class : Access_Class := Cmvc_Access_Control.Reader;
View_Or_Subsystem : String := "<SELECTION>";
Add_Execution_Rights : Boolean := True;
Response : String := "<PROFILE>");
-- Add the group to the list of groups that has access to the
-- designated view or subsystem. If the group is already on
-- the list then change the access to the designated value.
-- The ACLs for objects in the view or subsystem are
-- adjusted appropriately. If Add_Execution_Rights is set then
-- the group is also granted all execution rights that are
-- appropriate to the specified access class. Whether or not
-- Add_Execution_Rights is set, all inappropriate execution rights
-- are removed when the access class for a group is changed.
-- There is a limit of 7 groups that may have access to a subsystem
-- or view at any one time.
procedure Remove_Group (The_Group : String := "<ALL>";
View_Or_Subsystem : String := "<SELECTION>";
Response : String := "<PROFILE>");
-- Clear the access for the group from the specified view or subsystem.
-- If the group is <ALL> then access is restricted for all groups
-- with current access. All execution rights are also cleared.
procedure Display (For_Group : String := "<ALL>";
View_Or_Subsystem : String := "<CURSOR>";
Execution_Rights : Boolean := False;
Response : String := "<PROFILE>");
-- Display the current access control information for the specified
-- group. The symbol <ALL> specifies that all groups with access
-- are to be displayed. Execution rights are displayed if requested.
function Has_Access (User_Or_Group : String := "<USER>";
In_Class : Access_Class := Cmvc_Access_Control.Reader;
View_Or_Subsystem : String := "<CURSOR>";
Group_Only : Boolean := False;
Response : String := "<WARN>") return Boolean;
-- Determine if the user or group has the specified access to the
-- view or subsystem. If a user is named then all groups which
-- include the user are checked for the access. If a group is specified
-- then the group is checked for the specified access. If Group_Only
-- is specified then, group access is checked even if there exists
-- a user with the same name. The special symbol <USER> denotes
-- the current user.
------------------------------------------------------------------------
-- Execution Rights --
------------------------------------------------------------------------
type Execution_Right is new Natural range 0 .. 127;
-- Each command in Cmvc, Cmvc_Maintenance, or Cmvc_Hierarchy is
-- composed of "primitive operations" that correspond to the part
-- of the command that is applied to the different parameters.
-- An execution right is the capability to execute a primitive
-- operation on a view or a subsystem. There is an execution right
-- for each primitive operation. When a command is executed
-- the execution rights are checked for each primitive operation
-- involved in the command.
--
-- For example, when Cmvc.Accept_Changes is executed to move
-- changes from one view to another, the execution right
-- "Accept_Changes_Source" is checked on the source view and
-- the execution right "Accept_Changes_Destination" is checked on
-- the destination view.
--
-- Below are listed the various execution rights. The name of
-- each execution right is formed from the command it is primarily
-- associated with, as the first part of the name, and the
-- parameter (if more than one) as the second part of the name.
-- All appropriate rights, depending on the context
All_Rights : constant Execution_Right := 0;
-- Cmvc operations for views.
Check_Out : constant Execution_Right := 1;
Check_In : constant Execution_Right := 2;
Accept_Changes_Destination : constant Execution_Right := 3;
Accept_Changes_Source : constant Execution_Right := 4;
Abandon_Reservation : constant Execution_Right := 5;
Revert : constant Execution_Right := 6;
Modify_Notes : constant Execution_Right := 7;
Make_Controlled : constant Execution_Right := 8;
Make_Uncontrolled : constant Execution_Right := 9;
Sever : constant Execution_Right := 10;
Join_What : constant Execution_Right := 11;
Join_To : constant Execution_Right := 12;
Merge_Changes_Destination : constant Execution_Right := 13;
Merge_Changes_Source : constant Execution_Right := 14;
Release : constant Execution_Right := 15;
Copy : constant Execution_Right := 16;
Make_Path : constant Execution_Right := 17;
Make_Subpath : constant Execution_Right := 18;
Make_Spec_View : constant Execution_Right := 19;
Import_From : constant Execution_Right := 20;
Import_Into : constant Execution_Right := 21;
Remove_Import : constant Execution_Right := 22;
Replace_Model : constant Execution_Right := 23;
Destroy_View : constant Execution_Right := 24;
Make_Code_View : constant Execution_Right := 25;
Query_View : constant Execution_Right := 26;
-- Cmvc_Maintenance operations for views.
Check_Consistency : constant Execution_Right := 27;
-- Cmvc_Hierarchy operations for views
Build_Activity_In : constant Execution_Right := 28;
Build_Activity_From : constant Execution_Right := 29;
Expand_Activity : constant Execution_Right := 30;
-- Cmvc operations for subsystem.
Initial : constant Execution_Right := 31;
Destroy_Config : constant Execution_Right := 32;
Destroy_Subsystem : constant Execution_Right := 33;
Build : constant Execution_Right := 34;
Query_Subsystem : constant Execution_Right := 35;
Edit_Notes : constant Execution_Right := 36;
-- Cmvc_Maintenance operations for subsystems.
Expunge_Database : constant Execution_Right := 37;
Subsystem_Check_Consistency : constant Execution_Right := 38;
Update_Cdb : constant Execution_Right := 39;
Make_Primary : constant Execution_Right := 40;
Make_Secondary : constant Execution_Right := 41;
Destroy_Cdb : constant Execution_Right := 42;
-- Cmvc_Hierarchy operations for systems and subsystems
Add_Child_Parent : constant Execution_Right := 43;
Add_Child_Child : constant Execution_Right := 44;
Remove_Child : constant Execution_Right := 45;
procedure Add_Right (For_Group : String := "NETWORK_PUBLIC";
The_Right : Execution_Right :=
Cmvc_Access_Control.All_Rights;
View_Or_Subsystem : String := "<SELECTION>";
Response : String := "<PROFILE>");
-- Add the execution right for the group in the designated subsystem.
-- An execution right can only be added if it is appropriate to
-- the current access class for that group in the view or subsystem.
-- If the right is All_Rights then all rights which appropriate to
-- the group's access class are added.
procedure Remove_Right (For_Group : String := "<ALL>";
The_Right : Execution_Right :=
Cmvc_Access_Control.All_Rights;
View_Or_Subsystem : String := "<SELECTION>";
Response : String := "<PROFILE>");
-- Remove the designated execution right. If <ALL> is specified
-- for the group then the execution right is removed for all
-- groups with current rights.
function Has_Right (User_Or_Group : String := "<USER>";
The_Right : Execution_Right :=
Cmvc_Access_Control.All_Rights;
View_Or_Subsystem : String := "<CURSOR>";
Group_Only : Boolean := False;
Response : String := "<WARN>") return Boolean;
-- Determine if the user or group has the specifed execution right.
-- If The_Right is All_Rights or if Group_Only is set then the
-- name is interpreted as a group name. Also, if The_Right is All_Rights
-- then true is returned only if all rights appropriate to the current
-- access class are set.
------------------------------------------------------------------------
-- Miscellaneous Operations --
------------------------------------------------------------------------
procedure Check (View_Or_Subsystem : String := "<SELECTION>";
Repair_Inconsistencies : Boolean := False;
Response : String := "<PROFILE>");
-- Check that the current access classes for the view or subsystem
-- are compatible with ACLs on the objects in the views and/or subsystems.
-- If the ACLs on subobjects are not compatible with the access classes
-- and the current user has owner access to the view or subsystem and
-- Repair_Inconsistencies is set then the ACLs on the subobjects
-- will be reset.
--
-- Incompatible ACLs are either 1) ACL entries lacking access indicated
-- by the access of the view or subsystem, or 2) ACL entries for groups
-- without access to the view or subsystem.
-- Repair_Inconsistencies will repair both types. If Repair_Inconsistencies
-- is false then an error occurs if groups having access to the
-- view or subsystem are not correctly represented on an ACL lists.
-- A warning is issued if groups not having access to the view
-- or subsystem are found to be on the ACL of a subobject.
--
-- This procedure will also check that there are no entries for
-- groups that have been deleted. If there is such an entry and
-- Repair_Inconsistencies is false then an error occurs. If there
-- is an entry for a delete group and Repair_Inconsistencies is true
-- then the deleted entry will be removed from all ACL lists as
-- specified. This is the only way in which obsolete entries can
-- be deleted from access control state.
function Is_Consistent (View_Or_Subsystem : String := "<CURSOR>";
Response : String := "<WARN>") return Boolean;
-- Perform same consistency check as procedure above, does not
-- put out any warnings nor will it make any changes. Will also return
-- false if access control information does not exist or if the
-- current user does not have sufficient access to determine if
-- the information is consistent.
procedure Initialize (View_Or_Subsystem : String := "<SELECTION>";
Response : String := "<PROFILE>");
-- Initialize the access control information for a view or subsystem.
-- All groups that have owner access in the ACL of the view or
-- subsystem world are put into the owner access class. All groups
-- that have read access in the ACL, but not owner access, are
-- put into the reader access class. All appropriate execution rights
-- are set.
--
-- This operation is primarily useful for setting up access control
-- in subsystems or views that were created by previous environment
-- releases. It can also be applied to views or subsystems with
-- access control information in which case the view or subsystem
-- is reset to its just initialized state with only owners and
-- readers having access.
--
-- All commands in this package will fail (unless otherwise noted)
-- if access control information is not initialized or if the current
-- user does not have read access to the view or subsystem the
-- command is being applied to.
No_Access : exception;
-- Raised by Get_Access and Get_Rights if the group has no access.
function Get_Access (The_Group : String := "NETWORK_PUBLIC";
View_Or_Subsystem : String := "<CURSOR>";
Response : String := "<WARN>") return Access_Class;
-- Return the access class of a group with access to the view or
-- subsystem. If the group has no access then No_Access is raised.
type Group_Index is range 0 .. 6;
-- Index of a group that has access to a view or subsystem. Since,
-- there can be at most 7 groups with access to a view or subsystem
-- the groups are indexed from 0 to 6.
function Group_Name (The_Index : Group_Index := 0;
View_Or_Subsystem : String := "<CURSOR>";
Response : String := "<WARN>") return String;
-- Get the name of the group at the specified index. If no group
-- is at the index then returns "". Note that if index N is empty
-- then index N+1 is also empty.
------------------------------------------------------------------------
-- Execution Right Tables --
------------------------------------------------------------------------
-- In many instances, especially in building additional tools, it will
-- be useful to treat execution rights as a composite object. An
-- "execution table" is a table of all execution rights. The execution
-- rights for a particular group can set by providing a complete
-- execution table. Constant execution tables, corresponding to
-- rights appropriate for various access classes, are also provided.
type Execution_Table is array (Execution_Right) of Boolean;
-- Table of all possible execution rights.
Nil_Rights : constant Execution_Table := (others => False);
-- Setting execution rights to this prevents execution of any commands.
procedure Set_Rights (For_Group : String := "NETWORK_PUBLIC";
The_Rights : Execution_Table :=
Cmvc_Access_Control.Nil_Rights;
View_Or_Subsystem : String := "<SELECTION>";
Response : String := "<PROFILE>");
-- Set all the execution rights for the specified group in the view
-- or subsystem. Only rights appropriate to the groups access class
-- are actually set. Warnings are produced for inappropriate rights.
function Get_Rights (For_Group : String := "NETWORK_PUBLIC";
View_Or_Subsystem : String := "<CURSOR>";
Response : String := "<WARN>") return Execution_Table;
-- Return the execution rights for a group. If the group does not
-- have access to the view or subsystem then No_Access is raised.
------------------------------------------------------------------------
-- Constant Execution Right Tables --
------------------------------------------------------------------------
-- Below are constants describing the execution rights that appropriate
-- to various access classes.
-- Rights for a view that only require READER access to the view
View_Reader_Rights : constant Execution_Table :=
Execution_Table'(Accept_Changes_Source => True,
Join_To => True,
Merge_Changes_Source => True,
Query_View => True,
Expand_Activity => True,
others => False);
-- Rights for a view that only require CLIENT access to the view
View_Client_Rights : constant Execution_Table :=
Execution_Table'
(Import_From => True, Build_Activity_From => True, others => False)
or View_Reader_Rights;
-- Rights for a view that only require DEVELOPER access to the view
View_Developer_Rights : constant Execution_Table :=
Execution_Table'(Check_Out => True,
Check_In => True,
Accept_Changes_Destination => True,
Abandon_Reservation => True,
Revert => True,
Modify_Notes => True,
Make_Controlled => True,
Make_Uncontrolled => True,
Sever => True,
Join_What => True,
Release => True,
Make_Path => True,
Make_Subpath => True,
Make_Code_View => True,
Copy => True,
Make_Spec_View => True,
Merge_Changes_Destination => True,
Build_Activity_In => True,
others => False)
or View_Client_Rights;
-- Rights for a view that require OWNER access to the view
View_Owner_Rights : constant Execution_Table :=
Execution_Table'(Import_Into => True,
Remove_Import => True,
Replace_Model => True,
Destroy_View => True,
Check_Consistency => True,
others => False)
or View_Developer_Rights;
-- Rights for a subsystem that only require READER access to the subsystem
Subsystem_Reader_Rights : constant Execution_Table :=
Execution_Table'(Query_Subsystem => True, others => False);
-- Rights for a subsystem that only require CLIENT access to the subsystem
Subsystem_Client_Rights : constant Execution_Table :=
Execution_Table'(Add_Child_Child => True, others => False) or
Subsystem_Reader_Rights;
-- Rights for a subsystem that only require DEVELOPER access to the subsystem
Subsystem_Developer_Rights : constant Execution_Table :=
Execution_Table'(Edit_Notes => True,
Add_Child_Parent => True,
Remove_Child => True,
Update_Cdb => True,
others => False)
or Subsystem_Client_Rights;
-- Rights for a subsystem that require OWNER access to the subsystem
Subsystem_Owner_Rights : constant Execution_Table :=
Execution_Table'(Initial => True,
Destroy_Config => True,
Destroy_Subsystem => True,
Build => True,
Subsystem_Check_Consistency => True,
Expunge_Database => True,
Make_Primary => True,
Make_Secondary => True,
Destroy_Cdb => True,
others => False)
or Subsystem_Developer_Rights;
-- Rights for a view that only require READER access
-- to the enclosing subsystem
Subsystem_Reader_View_Rights : constant Execution_Table :=
Execution_Table'(Import_From => True,
Import_Into => True,
Remove_Import => True,
Replace_Model => True,
Query_View => True,
Build_Activity_In => True,
Build_Activity_From => True,
Expand_Activity => True,
others => False);
-- Rights for a view that only require CLIENT access
-- to the enclosing subsystem
Subsystem_Client_View_Rights : constant Execution_Table :=
Subsystem_Reader_View_Rights;
-- Rights for a view that only require DEVELOPER access
-- to the enclosing subsystem
Subsystem_Developer_View_Rights : constant Execution_Table :=
Execution_Table'(Check_Out => True,
Check_In => True,
Accept_Changes_Source => True,
Accept_Changes_Destination => True,
Abandon_Reservation => True,
Revert => True,
Modify_Notes => True,
Make_Controlled => True,
Make_Uncontrolled => True,
Sever => True,
Join_What => True,
Join_To => True,
Merge_Changes_Destination => True,
Merge_Changes_Source => True,
others => False)
or Subsystem_Client_View_Rights;
-- Rights for a view that require OWNER access
-- to the enclosing subsystem
Subsystem_Owner_View_Rights : constant Execution_Table :=
Execution_Table'(Release => True,
Copy => True,
Make_Path => True,
Make_Subpath => True,
Make_Spec_View => True,
Make_Code_View => True,
Destroy_View => True,
Check_Consistency => True,
others => False)
or Subsystem_Developer_View_Rights;
------------------------------------------------------------------------
pragma Subsystem (Cmvc);
pragma Module_Name (4, 3727);
pragma Bias_Key (12);
end Cmvc_Access_Control;package Cmvc_Hierarchy is
-- Operations to manipulate Cmvc "Systems". Each system has some
-- number of children which may be either subsystems or other
-- systems.
-- A system contains "system views". Each system view contains
-- an activity called the "release activity" which selects a
-- released view for each child subsystem of the system.
-- Thus, a system view describes a complete implementation of the
-- entire system in much the same way that a load view contains a
-- complete implementation of a subsystem.
-- Systems and system views are created by commands in the Cmvc.
-- Releasing a system view creates a new released system view.
procedure Add_Child (Child : String := ">>SYSTEM/SUBSYSTEM NAME<<";
To_System : String := "<CURSOR>";
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- This operation creates a structural link between the designated
-- system and child.
-- These links may not form cycles through child systems.
procedure Remove_Child (Child : String := ">>SYSTEM/SUBSYSTEM NAME<<";
From_System : String := "<CURSOR>";
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- The opposite of the operation above, this call will sever the
-- connection between a child and a parent.
procedure Build_Activity (Working_System_View : String := "<CURSOR>";
Views_To_Include : String := "<LATEST>";
Update_Imports : Boolean := True;
Allow_Code_Views : Boolean := False;
Comments : String := "";
Work_Order : String := "<DEFAULT>";
Response : String := "<PROFILE>");
-- Builds or updates the "release activity" in the working system view
-- to include the specified views. If <LATEST> is specified then
-- the latest releases of all the children of the system are included.
-- Spec views or releases are included in the release activity if
-- the views have been created after the last time that build_activity
-- was run on the specified working system view.
-- Path restrictions may be used to control which releases are included.
-- If Update_Imports is set then the system view is made to import
-- all of the subsystem views referenced by the release activity.
-- Note that this importing is subject to the normal compatibility
-- requirements.
-- If Allow_Code_Views is true then code-only views are treated like
-- release in that they can be included in the release activity.
-- Otherwise, only regular released views will be included in the
-- release activity.
procedure Expand_Activity (New_Activity : String := ">>NEW ACTIVITY NAME<<";
System_View : String := "<CURSOR>";
Response : String := "<PROFILE>");
-- Make a copy of a release activity which does not contain any
-- release views - replace all references to releases with the
-- contents of that release.
function Contents (Of_System_View : String := "<CURSOR>";
Recursive : Boolean := True;
Response : String := "<WARN>") return String;
-- Returns the contents of the release_activity of the system view.
function Children (Of_System : String := "<CURSOR>";
Recursive : Boolean := True;
Response : String := "<WARN>") return String;
-- This subprogram returns a list of the children of a system.
function Parents (Of_Subsystem : String := "<CURSOR>";
Recursive : Boolean := False;
Response : String := "<WARN>") return String;
-- This returns a list of parent Systems.
pragma Subsystem (Cmvc);
pragma Module_Name (4, 3702);
end Cmvc_Hierarchy;package Cmvc_Maintenance is
procedure Expunge_Database (In_Subsystem : String := "<CURSOR>";
Response : String := "<PROFILE>");
-- Free up space in the Database by first finding all configurations
-- in the database that no longer have objects and destroying them,
-- then destroying all elements and join sets (with all of their
-- generations) that are no longer referenced.
procedure Delete_Unreferenced_Leading_Generations
(In_Subsystem : String := "<CURSOR>";
Response : String := "<PROFILE>");
-- Not yet implemented
procedure Convert_Old_Subsystem (Which : String := "<SELECTION>";
Response : String := "<PROFILE>");
-- Convert all of the views in a subsystem to CMVC subsystems. This
-- command can convert more than one subsystem per call.
procedure Check_Consistency (Views : String := "<CURSOR>";
Response : String := "<PROFILE>");
-- Verify that all of the views are consistent with the CMVC invariants.
-- Checks that:
-- The configurations all exist and are correct.
-- There are no dangling controlled objects.
-- The imports are ok, and that all of the imported subsystems
-- record the reference.
-- Various other things.
------------------------------------------------------------------------
-- User level commands for manipulating the compatibility database (CDB)
-- associated with subsystems.
------------------------------------------------------------------------
procedure Display_Cdb (Subsystem : String := "<CURSOR>";
Show_Units : Boolean := False;
Response : String := "<PROFILE>");
-- Displays a summary of the information in the CDB. If "show_units"
-- is true, then a summary of information for the units currently
-- known in the subsystem is also displayed.
procedure Make_Primary (Subsystem : String := "<SELECTION>";
Moving_Primary : Boolean := False;
Response : String := "<PROFILE>");
-- Makes the subsystem into a primary subsystem with its own read/write
-- CDB. If the subsystem was a primary this operation is a no-op. If
-- the subsystem is a secondary then a new subsystem_id is assigned.
-- If "moving_primary" is set to true, then the location of the
-- primary for this subsystem is being moved and the current subsystem_id
-- will be used. When moving a primary the user must make sure
-- that the original primary is either destroyed or converted into
-- a secondary to prevent corruption of the CDB.
procedure Make_Secondary (Subsystem : String := "<SELECTION>";
Response : String := "<PROFILE>");
-- Makes the subsystem into a secondary with the same subsystem_id.
procedure Destroy_Cdb (Subsystem : String := "<SELECTION>";
Limit : String := "<WORLDS>";
Effort_Only : Boolean := True;
Response : String := "<PROFILE>");
-- Destroys the CDB and all remnants of it in compiled units.
-- This includes demoting ALL units in the subsystem to source
-- and deleting all code-only views. If "effort-only" is set
-- to true, then the effects of the operation are computed
-- and displayed.
procedure Update_Cdb (From_Subsystem : String := "<ASSOCIATED_PRIMARY>";
To_Subsystem : String := "<SELECTION>";
Response : String := "<PROFILE>");
-- Moves the CDB from one subsystem to another using the network
-- if necessary. Both subsystems must have the same subsystem_id.
procedure Repair_Cdb (Subsystem : String := "<SELECTION>";
Verify_Only : Boolean := True;
Delete_Current : Boolean := False;
Response : String := "<PROFILE>");
-- Will rebuild the CDB to be consistent with the currently compiled
-- units in the subsystem. If "verify_only" is true then the CDB
-- will not be changed, but will be checked for consistency with
-- the currently compiled units. If "verify_only" is false and
-- "delete_current" is true then the current CDB will be deleted
-- and then rebuilt. If the "verify_only" is false and
-- "delete_current" is false then existing entries in the CDB
-- will be verified and missing entries will be added.
procedure Display_Code_View (View : String := "<CURSOR>";
Verbose_Unit_Info : Boolean := False;
Show_Map_Info : Boolean := False;
Response : String := "<PROFILE>");
-- Display information about the code view.
-- The units in the code view are displayed. If "verbose_unit_info"
-- is set then context dependencies and other unit information is
-- displayed. If "show_map_info" is set then the mapping of
-- code segments and exceptions from the code view to the original
-- view is displayed.
pragma Subsystem (Cmvc);
pragma Module_Name (4, 3707);
end Cmvc_Maintenance;package Command is
procedure Diana_Edit (Name : String := "<IMAGE>");
procedure Spawn;
procedure Debug;
procedure Make_Procedure (Name : String := ">>Simple Procedure Name<<";
Context : String := "$");
-- Creates a procedure of the given Name in the given Context whose body is
-- the contents of the command window that contains the cursor. With
-- clauses are added to the procedure definition as needed so that
-- unqualified names will semanticize correctly. Also, if needed, a
-- Links.Add is attempted. This is an interactive command only. The command
-- creates an Ada Editor window, builds the procedure, and leaves the
-- cursor in that window when it is complete. Error messages will appear in
-- the message window.
pragma Subsystem (Command);
pragma Module_Name (4, 2212);
end Command;package Common is
procedure Abandon (Window : String := "<IMAGE>");
-- Release all locks, and delete the associated window.
-- This causes the loss of any editing changes.
procedure Clear_Underlining;
-- Remove underlining marks left on the image by previous commands.
procedure Commit;
-- Make changes to the image permanent
procedure Complete (Menu : Boolean := True);
-- Make the current image complete. Provides syntactic and semantic
-- completion, as possible.
-- Menu => bring up a menu window for ambiguous references
procedure Create_Command;
-- Go to the command window for the current image, creating one if
-- necessary.
procedure Definition (Name : String := "<CURSOR>";
In_Place : Boolean := False;
Visible : Boolean := True);
-- Bring up the appropriate image to show the designated object.
-- Do not make the image modifiable. If a new window is required
-- In_Place indicates that the current frame should be used. Visible
-- controls how names that resolve to both a visible part and a body
-- should be resolved. Visible causes the visible part to be pre-
-- ferred; not Visible brings up the body if that is possible
procedure Edit (Name : String := "<IMAGE>";
In_Place : Boolean := False;
Visible : Boolean := True);
-- Bring up the appropriate image to show the designated object.
-- Attempt to make the image modifiable.
-- In_Place and Visible are as in Definition.
procedure Enclosing (In_Place : Boolean := False;
Library : Boolean := False);
-- Bring up the image for the object enclosing this one.
-- In_Place is as in Definition.
-- Library => the resulting image should be a Library; e.g. for Ada
-- subunits, go to the enclosing directory rather than parent body.
procedure Elide (Repeat : Positive := 1);
-- Reduce the level of detail presented by the number of levels
-- specified. Attempts to expand beyond maximum level have no effect.
-- It is not expected that Elide will reorder the presentation.
procedure Expand (Repeat : Positive := 1);
-- Increase the level of detail presented by the number of levels
-- specified. Attempts to expand beyond maximum level have no effect.
-- It is not expected that Expand will reorder the presentation.
procedure Explain;
-- Provide additional information about the indicated object.
-- The additional information may take the form of more detailed
-- display or error message explanation. If more detailed infor-
-- mation is supplied, repeated applications cause the display to
-- cycle through the available presentations. For Ada, provides
-- text of messages associated with underlinings.
procedure Format;
-- Format the current image appropriately for its image type.
procedure Revert;
-- Restore the image to the reflect the state of the underlying object.
-- This causes the loss of any editing changes.
procedure Release (Window : String := "<IMAGE>");
-- Make changes to the designated image permanent (if applicable),
-- release all locks, and delete the associated window
procedure Semanticize;
-- Perform semantic checking on the image.
procedure Sort_Image (Format : Integer := 1);
-- Sort the display according to the given format. Format numbering is
-- specific to the object type. It is assume that if format 1 sorts by
-- increasing values that format -1 will sort by decreasing values of
-- the same key. Clearly not relevant to all object types.
procedure Demote;
-- Bring the image to the next lower state.
procedure Promote;
-- Bring image to the next higher state.
procedure Redo (Repeat : Positive := 1);
-- Inverse of Undo
procedure Undo (Repeat : Positive := 1);
-- restore the contents of the image to the previous consistent state
procedure Insert_File (Name : String := "<REGION>");
-- Insert the contents of the indicated file into the current image
procedure Write_File (Name : String := ">>FILE NAME<<");
-- Write the contents to the named text file
package Object is
procedure Insert;
procedure Copy;
procedure Delete;
procedure Move;
procedure Previous (Repeat : Positive := 1);
procedure Next (Repeat : Positive := 1);
procedure Parent (Repeat : Positive := 1);
procedure Child (Repeat : Positive := 1);
procedure First_Child (Repeat : Positive := 1);
procedure Last_Child (Repeat : Positive := 1);
end Object;
pragma Subsystem (Object_Editor);
pragma Module_Name (4, 2215);
end Common;with Action;
package Compilation is
subtype Name is String;
subtype Unit_Name is String;
-- All names are resolved in the established naming context for the job.
-- A parameter of type Unit_Name may designate a set of Ada units,
-- Worlds, Directories, or Activities. If a world or directory is
-- designated, all Ada units contained by that world or directory are
-- operated on. If an activity is given, all Ada units in the views
-- specified by the Activity are operated on.
type Unit_State is (Archived, Source, Installed, Coded);
subtype Change_Limit is String;
-- Parameters of type Change_Limit control which units an operation is
-- allowed to change in order to perform its task. Three special values
-- are predefined:
Same_Directories : constant Change_Limit := "<DIRECTORIES>";
Current_Directory : constant Change_Limit := Same_Directories;
-- Only units in the same directories as the units specified to the
-- operation are allowed to change.
Same_Worlds : constant Change_Limit := "<WORLDS>";
Same_World : constant Change_Limit := Same_Worlds;
-- Only units in the same worlds as the units specified to the operation
-- are allowed to change.
All_Worlds : constant Change_Limit := "<ALL_WORLDS>";
-- A unit in any world may be changed.
-- A Change_Limit parameter may also be a string name that designates a
-- set of worlds, directories or activities. Only units in the
-- designated worlds or directories are allowed to change. The set of
-- worlds designated by an activity is the set of views referenced by
-- that activity.
procedure Demote (Unit : Unit_Name := "<SELECTION>";
Goal : Unit_State := Compilation.Source;
Limit : Change_Limit := "<WORLDS>";
Effort_Only : Boolean := False;
Response : String := "<PROFILE>");
-- All units that must be demoted in order to demote the specified
-- unit will be demoted if possible. Any messages are appended to the
-- log file.
procedure Parse (File_Name : Name := "<REGION>";
Directory : Name := "$";
List : Boolean := False;
Source_Options : String := "";
Response : String := "<PROFILE>");
-- The named file must contain Ada source for a compilation. After it
-- is parsed, the library compilation units are placed in the designated
-- Directory. LIST => true generates a listing of the input file into
-- the log file. Wildcards in the File_Name are supported.
type Promote_Scope is (Single_Unit, Unit_Only, Subunits_Too,
All_Parts, Load_Views);
procedure Promote (Unit : Unit_Name := "<IMAGE>";
Scope : Promote_Scope := Compilation.Subunits_Too;
Goal : Unit_State := Compilation.Installed;
Limit : Change_Limit := "<WORLDS>";
Effort_Only : Boolean := False;
Response : String := "<PROFILE>");
-- Attempts to promote the units designated by the Unit parameter to the
-- designated Goal. The operation is a no-op if the units are already at
-- or beyond the goal state.
-- Unless the Scope is Single_Unit, Promote will attempt to promote the
-- ancestor units of, the visible part of, and any units with'ed by the
-- designated units before promoting the designated units. The with'ed
-- units must exist in the libraries specified by the Limit parameter.
-- Promotion of other units is NOT attempted; specifically: promotion of
-- siblings is NOT attempted. If a designated unit is a visible part,
-- promotion of the body is NOT attempted.
-- Scope => Subunits_Too will cause subunits to be promoted.
-- Scope => All_Parts is equivalent to the Make procedure described below.
-- Scope => Load_Views is an even wider scope than All_Parts, in that it
-- will look through the current activity and try to make units
-- in referenced load views.
-- Semantic messages are attached to the tree. Semantic and other
-- messages are appended to the end of the Log_File.
procedure Make (Unit : Unit_Name := "<IMAGE>";
Scope : Promote_Scope := Compilation.All_Parts;
Goal : Unit_State := Compilation.Coded;
Limit : Change_Limit := "<WORLDS>";
Effort_Only : Boolean := False;
Response : String := "<PROFILE>") renames Promote;
-- Same as Promote except that an attempt is made to promote the
-- secondary units of each visible part promoted.
procedure Delete (Unit : Unit_Name := "<SELECTION>";
Limit : Change_Limit := "<WORLDS>";
Response : String := "<PROFILE>");
-- Demotes and deletes the default version of the named unit and its
-- subunits.
procedure Destroy (Unit : Unit_Name := "<SELECTION>";
Threshold : Natural := 1;
Limit : Change_Limit := "<WORLDS>";
Response : String := "<PROFILE>");
-- Deletes and expunges all versions of the named unit and its subunits.
-- Wildcard notation may be used to specify more than one unit to be
-- destroyed. The Threshold is the number of objects to be destroyed per
-- unit specified.
procedure Compile (File_Name : Name := "<REGION>";
Library : Name := "$";
Goal : Unit_State := Compilation.Installed;
List : Boolean := False;
Source_Options : String := "";
Limit : Change_Limit := "<WORLDS>";
Response : String := "<PROFILE>");
-- Parses and promotes the units in the given file_name(s) (wildcards
-- allowed) to the given Goal state in the given Library according to
-- the Chapter 10 LRM rules for libraries. If List is true a source
-- listing with interleaved error messages will be generated to the log
-- file.
procedure Dependents (Unit : Unit_Name := "<IMAGE>";
Transitive : Boolean := False;
Response : String := "<PROFILE>");
-- Displays the installed units that depend on (with) the given unit(s);
procedure Atomic_Destroy (Unit : Unit_Name;
Success : out Boolean;
Action_Id : Action.Id := Action.Null_Id;
Limit : Change_Limit := "<WORLDS>";
Response : String := "<PROFILE>");
-- Deletes and expunges all versions of the named unit and its subunits.
-- Wildcard notation may be used to specify more than one unit to be
-- destroyed. The operation succeeds only if all designated units can
-- be destroyed.
procedure Load (From : String := ">>MAIN_PROGRAM NAME<<";
To : String := ">>LOADED_MAIN NAME<<";
Response : String := "<PROFILE>");
-- Produce a Loaded_Main program from the main program specified by From.
-- Put the result at To.
procedure Set_Target_Key (The_Key : String := "?";
To_World : String := "<IMAGE>";
Response : String := "<PROFILE>");
-- Assign the target key to the specified world. Once a key has
-- been assigned to a world, the assignment can be changed only if
-- the new key and the old key differ only in the front end/back end
-- policy sub-components. The default Key string, "?", causes a
-- list of all available keys to be displayed.
procedure Show_Target_Key (For_World : String := "<IMAGE>";
Response : String := "<PROFILE>");
-- Displays in the log the target key currently assigned to the
-- indicated world.
function Get_Target_Key (For_World : String := "<IMAGE>") return String;
-- returns the image of the target key assigned to the indicated
-- world.
pragma Subsystem (Commands);
pragma Module_Name (4, 3936);
end Compilation;with Calendar;
package Daemon is
-- There are five types of Daemon tasks controlled by this package, their
-- characteristics and default scheduling:
--
-- Snapshot. Frequent. ~1 minute slowdown. Hourly.
--
-- Action. Frequent, unobtrusive. Every two hours.
--
-- Weekly. Unobtrusive. Weekly at 2:30 AM.
-- Code_Segment Group Session Tape Terminal User
--
-- Daily. Variable, possibly significant interruption.
-- Nightly at 3:00 AM.
-- Ada DDB Directory Error_Log File Disk
--
-- Disk. Daily or as needed. Prolonged slowdown.
-- Last portion of the Daily run
--
-- If no other action is taken, all clients will be scheduled at a
-- frequency and time normally appropriate. These schedules can be
-- changed to suit specific needs. Note that Disk is included in the
-- Daily category and will be run with the other Daily Daemons.
--
-- Clients that interfere with normal operations warn all users.
--
-- There is a group of clients referred to as Major_Clients that are
-- expected to be of interest in monitoring the state of the machine:
-- Snapshot, Action, Disk, Ada, DDB, Directory, and File.
Major_Clients : constant String := "*";
procedure Run (Client : String := "Snapshot";
Response : String := "<PROFILE>");
-- Cause the named Client to run the specified operation immediately;
-- Has no effect on the next scheduled run of Client.
procedure Schedule (Client : String := ">>CLIENT NAME<<";
Interval : Duration;
First_Run : Duration := 0.0;
Response : String := "<PROFILE>");
-- Sets the interval at which the Client operation will take place.
procedure Quiesce (Client : String := ">>CLIENT NAME<<";
Additional_Delay : Duration := 86_400.0;
Response : String := "<PROFILE>");
-- Reschedule the Client not to run at the next scheduled time.
-- Equivalent to Schedule with a new First_Run, but the same Interval.
-- Defaults to a 1-day delay; use Duration'Last for indefinite delay.
procedure Status (Client : String := "*");
-- print a formatted display of current status for given Client
-- Matches on prefix of Client name, "" is prefix of all clients
-- Major Clients (*): Actions, Ada, DDB, Directory, Disk, File, Snapshot
-- The Disk Client provides additional information when run separately.
procedure Warning_Interval (Interval : Duration := 120.0);
function Get_Warning_Interval return Duration;
-- Warning given before starting Daily clients to allow time to Quiesce.
function In_Progress (Client : String) return Boolean;
function Next_Scheduled (Client : String) return Calendar.Time;
function Last_Run (Client : String) return Calendar.Time;
function Interval (Client : String) return Duration;
procedure Get_Size (Client : String;
Size : out Long_Integer;
Size_After_Last_Run : out Long_Integer;
Size_Before_Last_Run : out Long_Integer);
-- Sizes are set to -1 if invalid
-- Control of the Disk Daemon
--
-- The Disk Daemon runs in response to a number of stimuli:
--
-- Daemon.Schedule Runs at priority 6; intended for machine idle.
-- Daemon.Run Runs at priority -1; background collection.
-- Daemon.Collect Runs at specified priority
-- over threshold Starts at priority 0 with escalation
--
-- Messages to all users are issued for each of the three explicitly
-- called collections. In addition, a message is sent when a Set_Priority
-- is called and it causes a change in priority.
--
-- A background task monitors over threshold situations and sends messages
-- of interesting events. Threshold_Warnings (False) allows an
-- installation-provided job to tailor policy.
--
-- Additional control over Disk operations is available in the
-- Disk_Daemon tools package.
subtype Volume is Integer range 0 .. 31;
subtype Collection_Priority is Integer range -1 .. 6;
-- -1 is the default and implies very low-level background activity
-- 0 guarantees progress in collection but has some effect on response
-- 6 causes collection to take over the machine
procedure Collect (Vol : Volume; Priority : Collection_Priority := 0);
-- If this call initiates a collection, it waits for its completion.
procedure Set_Priority (Priority : Collection_Priority := -1);
-- Set the priority of a currently running collection to Priority
procedure Threshold_Warnings (On : Boolean := True);
-- Cause messages to be sent when collection thresholds are passed.
--
-- Control of snapshot messages
--
procedure Snapshot_Warning_Message (Interval : Duration := 120.0);
procedure Snapshot_Start_Message (On : Boolean := True);
procedure Snapshot_Finish_Message (On : Boolean := True);
procedure Show_Snapshot_Settings;
procedure Get_Snapshot_Settings (Warning : out Duration;
Start_Message : out Boolean;
Finish_Message : out Boolean);
-------------------------------------------------------------------------
--
-- Control of the contents and permanence of the operations error log
--
-------------------------------------------------------------------------
type Condition_Class is (Normal, Warning, Problem, Fatal);
type Log_Threshold is (Console_Print, Log_To_Disk, Commit_Disk);
procedure Show_Log_Thresholds;
procedure Set_Log_Threshold (Kind : Log_Threshold; Level : Condition_Class);
function Get_Log_Threshold (Kind : Log_Threshold) return Condition_Class;
-- Options on client compactions.
--
-- Consistency checking does additional work to assure that the internal
-- state of the system is as it seems. This is normally only run when
-- there are suspected problems. Consistency checking slows operations
-- for which it is meaningful by between one and three orders of magnitude.
--
-- Access_List_Compaction is the process of removing non-existent groups
-- from the access lists of objects. This condition occurs when groups
-- are removed from the machine. Access_List_Compaction is only done
-- for Ada, Directory and File clients. All other clients reqested will
-- be silently ignored. All three must be compacted for any old group
-- numbers to be freed.
--
-- The default is disabled. The default is restored after
-- the next appropriate daemon run has completed.
procedure Set_Consistency_Checking (Client : String := "";
On : Boolean := True;
Response : String := "<PROFILE>");
function Get_Consistency_Checking (Client : String := "") return Boolean;
procedure Set_Access_List_Compaction (Client : String := "";
On : Boolean := True;
Response : String := "<PROFILE>");
function Get_Access_List_Compaction (Client : String := "") return Boolean;
pragma Subsystem (Os_Commands);
pragma Module_Name (4, 3932);
end Daemon;package Debug is
subtype Path_Name is String;
subtype Task_Name is String;
subtype Exception_Name is String;
subtype Hex_Number is String;
-- A Path_Name is used to reference declarations, objects, statements,
-- stack frames, tasks or types within progam units.
-- Many commands take both a Path_Name and a Stack_Frame. Though
-- the Path_Name type allows the specification of a stack frame, the
-- addition of the Stack_Frame parameter as a numeric value makes it
-- possible to specify the stack frame as a numeric argument from the
-- keyboard. If both a Stack_Frame and Path_Name are specified, the
-- Path_Name will be interpreted as the string Stack_Frame & Path_Name.
-- Task_Name may be either a hex number or string name for the task.
-- Exception_Name may be either a simple name for a predefined exception,
-- or a pathname to an Ada identified.
-- A Task_Name parameter of "all" specifies all tasks. A Task_Name
-- parameter of "" is interpreted as the control context task if explicitly
-- set, otherwise, all tasks. Exceptions to this rule are the commands
-- Run and Stack, for which a Task_Name parameter of "" specifies the
-- last task to stop if the control context is not explicitly set.
-- Commands to terminate debugging
procedure Debug_Off (Kill_Job : Boolean := False);
-- Debug_Off terminates debugging on the job. The job will run to
-- completion if Kill_Job is false. Otherwise, the job is terminated.
procedure Kill (Job : Boolean := True; Debugger : Boolean := False);
-- Kill can be used to kill either the job being debugged, or the
-- debugger itself.
-- Commands to query and modify program state
procedure Put (Variable : Path_Name := "<SELECTION>";
Stack_Frame : Integer := 0);
-- Display the value of the given object.
procedure Stack (For_Task : Task_Name := "";
Start : Integer := 0;
Count : Natural := 0);
-- Display Count stack frames for the specified task starting from frame
-- Start.
procedure Modify (New_Value : String := "";
Variable : Path_Name := "<SELECTION>";
Stack_Frame : Integer := 0);
-- Modify the value of the given object.
-- Commands to display ADA source
procedure Display (Location : Path_Name := "<SELECTION>";
Stack_Frame : Integer := 0;
Count : Natural := 0);
-- Display the source code for the given Location in the debugger window.
-- If the Location specifies a subprogram, package, or task, display
-- Count lines of source code including line numbers.
procedure Source (Location : Path_Name := ""; Stack_Frame : Integer := 0);
-- Like Definition, display the Location in an ada image.
-- Breakpoint handling commands; break 0 represents all breaks
procedure Break (Location : Path_Name := "<SELECTION>";
Stack_Frame : Integer := 0;
Count : Positive := 1;
In_Task : Task_Name := "";
Default_Lifetime : Boolean := True);
-- Set a break at the given location for the specified task. Count is
-- the number of times the location is executed before the break is active.
-- When Default_Lifetime is true, the breakpoint is temporary or permanent
-- as specified by the Permanent_Breakpoints option; if false, its
-- permanence is the opposite of the option.
-- The breakpoint will be given a unique number which can be used as the
-- breakpoint parameter of the Remove and Activate commands.
procedure Remove (Breakpoint : Natural; Delete : Boolean := False);
-- Deactivate the given breakpoint. With delete false, the breakpoint
-- can be installed again with the Activate command.
-- Use Show (Breakpoints) to display breaks.
procedure Activate (Breakpoint : Natural);
-- Install a previously removed breakpoint.
-- Commands to control all or individual tasks
procedure Stop (Name : Task_Name := "");
-- Stops execution of the specified task and keeps it stopped until
-- started by a call to Execute or Run naming the task or "all".
procedure Execute (Name : Task_Name := "");
-- Starts execution of the specified task if stopped.
procedure Xecute (Name : Task_Name := "");
-- same as Execute.
procedure Hold (Name : Task_Name := "");
-- Stops execution of the specified task and put it in the held state
-- until explicitly released by the command Release or a call to Execute or
-- Run explicitly naming this task. The held state differs from the
-- stopped state in that Execute ("all") will not run a held task.
procedure Release (Name : Task_Name := "");
-- Releases a task from the held state and moves it to the stopped
-- state. The task can then be started by a call to Execute or Run naming
-- the task or "all".
type Task_Category is
(All_Tasks, -- all known tasks
Blocked, -- tasks not in debugger, but not currently running
Held, -- tasks held in debugger (Hold command)
Not_Running, -- tasks not running for any reason
Running, -- tasks that are currently ready to run
Stopped); -- tasks stopped in the debugger (eg, at breakpoints)
procedure Task_Display (For_Task : Task_Name := "";
Task_Set : Task_Category := Debug.All_Tasks);
-- Display information about tasks in the given category.
type Stop_Event is
(About_To_Return, -- stop after last statement of a subprogram
Begin_Rendezvous, -- stop before first statement of accept body
End_Rendezvous, -- stop after last statement of accept body
Local_Statement, -- stop before next statement at same level
Machine_Instruction, -- stop before next instruction
Procedure_Entry, -- stop before first stmt/decl of called proc
Returned, -- stop before next statement in caller
Statement); -- stop before next statement
procedure Run (Stop_At : Stop_Event := Debug.Statement;
Count : Positive := 1;
In_Task : Task_Name := "");
-- Execute the specified task until the stop event has occurred
-- Count times.
procedure Clear_Stepping (For_Task : Task_Name := "");
-- Cancel any stepping operations for the given task.
-- Exception handling commands
procedure Catch (Name : Exception_Name := "<SELECTION>";
In_Task : Task_Name := "";
At_Location : Path_Name := "");
-- Stop execution when the specified exception is raised. Can be
-- limited to a particular task or location. Name = "all" catches
-- all exceptions; Name = "implicit" will catch implicitly raised
-- exceptions.
procedure Propagate (Name : Exception_Name := "<SELECTION>";
In_Task : Task_Name := "";
At_Location : Path_Name := "");
-- Request that execution not be stopped when the given exception is raised.
procedure Forget (Name : Exception_Name := "<SELECTION>";
In_Task : Task_Name := "";
At_Location : Path_Name := "");
-- Cancel a catch or propagate request.
-- Tracing commands
type Trace_Event is
(All_Events, -- Produce message for all of below
Call, -- Message for each subprogram entry
Exception_Raised, -- Message for each exception raised
Machine_Instruction, -- Message for each statement/decl
Propagate_Exception, -- Message for each frame popped by propagation
Rendezvous, -- Message for each rendezvous start and end
Statement); -- Message for each statement/decl
procedure Trace (On : Boolean := True;
Event : Trace_Event := Debug.All_Events;
In_Task : Task_Name := "";
At_Location : Path_Name := "<SELECTION>";
Stack_Frame : Integer := 0);
-- Enable or disable tracing. Tracing displays information about
-- the execution of the given_task when the specified Trace_Events
-- occur.
procedure Trace_To_File (File_Name : String := ">> FILE NAME <<");
-- Send trace output to the specified file. The null string
-- causes output to go to the debugger window.
-- History commands
procedure History_Display (Start : Integer := 0;
Count : Integer := 0;
For_Task : Task_Name := "");
-- Display Count history entries for the given task. If Start is positive,
-- it specifies the starting location from the newest entry; if negative,
-- from the oldest entry.
procedure Take_History (On : Boolean := True;
Event : Trace_Event := Debug.All_Events;
For_Task : Task_Name := "";
At_Location : Path_Name := "<SELECTION>";
Stack_Frame : Integer := 0);
-- Enable or disable history taking for the given task and location.
-- Commands to query debugger state
type Context_Type is (Control, Evaluation);
procedure Context (Set : Context_Type := Debug.Control;
To_Be : Path_Name := "<SELECTION>";
Stack_Frame : Integer := 0);
-- Set either the control or evaluation context. Control context
-- is generally used when a Task_Name parameter of "" is specified.
-- The evaluation context is used as a prefix for unqualified location
-- and object names.
type Option is
(Addresses, -- Include machine information
Break_At_Creation, -- Tasks stop before first decl
Declaration_Display, -- Include declarations in program display
Delete_Temporary_Breaks, -- Delete (vs deactivate) temp breakpoints
Display_Creation, -- Trace message for each task creation
Echo_Commands, -- Echo command in debugger window
Freeze_Tasks, -- Stop all tasks when one stops
Include_Packages, -- Task display includes packages
Interpret_Control_Words, -- Memory display for control stacks
Kill_Old_Jobs, -- Kill last debug job when next is begun
Machine_Level, -- Allow certain machine level operations
No_History_Timestamps, -- History display option
Optimize_Generic_History, -- No generic instance in history
Permanent_Breakpoints, -- Default breakpoints to permanent (vs temp)
Put_Locals, -- Put displays locals as well as parameters
Qualify_Stack_Names, -- Use fully qualified names in stack display
Require_Debug_Off, -- Debug_Off needed before debug next job
Save_Exceptions, -- Save exception-handling state across jobs
Show_Location, -- Display source in image when task stops
Timestamps); -- Include timestamps in command log
procedure Enable (Variable : Option; On : Boolean := True);
procedure Disable (Variable : Option; On : Boolean := False) renames Enable;
-- Enable or disable the specified option.
type Numeric is
(Display_Count, -- Default for Count in Display command
Display_Level, -- Number of levels to expand Put command's data
Element_Count, -- Max elements of array for Put to display
First_Element, -- Offset for start of Put's array display
History_Count, -- Default for Count in History_Display
History_Entries, -- History buffer size
History_Start, -- Default for Start in History_Display
Memory_Count, -- Default for Memory_Dump Count parameter
Pointer_Level, -- Number of pointers to expand in Put's data
Stack_Count, -- Default frame Count for Stack command
Stack_Start); -- Default for Start in Stack command
procedure Set_Value (Variable : Numeric; To_Value : Integer);
procedure Flag (Variable : String := ""; To_Value : String := "TRUE");
type State_Type is (All_State, Breakpoints, Contexts,
Exceptions, Flags, Histories, Libraries,
Special_Types, Steps, Stops_And_Holds, Traces,
-- internal debugger state
Active_Items, Exception_Cache, Inner_State, Statistics);
procedure Show (Values_For : State_Type := Debug.Breakpoints);
-- Display information about various debugger facilities.
type Information_Type is (Exceptions, Rendezvous, Space);
procedure Information (Info_Type : Information_Type := Debug.Exceptions;
For_Task : Task_Name := "");
-- Display information about the specified task.
procedure Comment (Information : String := "");
-- place a comment in the debugger window.
procedure Set_Task_Name (For_Task : Task_Name := "";
To_Name : String := "");
-- Set a task synonym for the specified task for use as a Task_Name
-- parameter to commands.
procedure Convert (Number : String := ""; To_Base : Natural := 0);
-- Hex/decimal conversion.
procedure Reset_Defaults;
-- Reset flags to initial values.
-- Unregister all special types.
procedure Current_Debugger (Target : String := "");
-- Set current debugger to the current window, or Target if
-- specified. Subsequent calls to Debug will be directed to
-- the specified target or native debugger.
-- Machine-level commands
-- For the following commands, address format is #Segment, #Offset
-- memory format is one of CONTROL, TYP, QUEUE, DATA, IMPORT, CODE, SYSTEM
procedure Memory_Display (Address : String := "";
Count : Natural := 0;
Format : String := "DATA");
procedure Location_To_Address (Location : Path_Name := "<SELECTION>";
Stack_Frame : Integer := 0);
procedure Address_To_Location (Address : String := "");
procedure Exception_To_Name (Implementation_Image : String := "");
procedure Memory_Modify (Address : String := ">>HEX ADDRESS<<";
Value : String := ">>HEX VALUE<<";
Width : Natural := 0;
Format : String := "DATA");
-- The format string is used to distinguish various addressing modes.
-- Width is interpreted according to the machine, where 0 is the
-- natural word width.
procedure Register_Display (Name : String := "";
For_Task : Task_Name := "";
Stack_Frame : Integer := 0;
Format : String := "");
-- "" implies display of interesting registers.
-- "ALL" displays all possible machine registers.
procedure Register_Modify (Name : String := ">>REGISTER NAME<<";
Value : String := ">>HEX VALUE<<";
For_Task : Task_Name := "";
Stack_Frame : Integer := 0;
Format : String := "");
procedure Object_Location (Variable : Path_Name := "<SELECTION>";
Options : String := "");
-- Display the machine location of the given Object.
-- Options describe various target specific kinds of information
-- to display.
procedure Attach_Process (Name : String := ""; Options : String := "");
-- Register the named process for control under the current debugger.
procedure Target_Request (Options : String := ""; To_File : String := "");
-- Perform target specific requests.
-- Output can be directed to the Debugger Window or to some other
-- file or device. Null value indicates debugger window.
procedure Connect (Remote_Machine : String := ""; Target : String := "");
-- Hook up a debugger to given machine.
-- Target should specify a target key - "" implies we can calculate
-- the target from the remote machine name.
procedure Invoke (Main_Unit : String := "<IMAGE>";
Options : String := "";
Spawn_Job : Boolean := True);
-- Find or start a debugger to the given machine, and start debugging
-- the indicated job.
procedure Reconnect;
-- attempt to reestablish communication after failure
pragma Subsystem (Native_Debugger);
pragma Module_Name (4, 3801);
end Debug;package Debug_Maintenance is
procedure Wait_For_Job;
-- Hang while debugger has running flag on. Returns when program
-- stops in debugger.
procedure Show_Version;
-- display the version of the current debugger;
pragma Subsystem (Native_Debugger);
pragma Module_Name (4, 3805);
end Debug_Maintenance;package Dependents is
type Display_Kind is (Subsystems, Views, Units, Parents, Item_Kinds,
Units_And_Kinds, Units_And_Items, Parents_And_Items);
type Dependents_Level is (Unfiltered, Immediate,
Reference_Closure, Demote_Closure);
procedure Show (Name : String := "<CURSOR>";
Display : Display_Kind := Dependents.Units;
Level : Dependents_Level := Dependents.Unfiltered;
Limit : String := "<ALL_WORLDS>";
Global : Boolean := True;
Options : String := "");
--
-- invoke the dependents object_editor.
--
-- dependents are entities which depend on the identifier specified
-- by the first argument. this dependence can be because of a direct
-- naming of that identifier, because of being the second part of a
-- two part item or because of a closure computation.
-- dependents can be either compilation units or constructs
-- within compilation units.
--
-- in the comments that follow the term "unit" will mean a
-- compilation unit.
-- the term "item" will refer to a construct within a compilation unit.
-- the term "main_item" will refer to the unit or item whose
-- dependents are being shown.
-- the term "kind" will refer to the kind of an item.
-- the term "parent" will refer to an ada program unit.
--
-- the first argument to dependents.show can be a naming expression
-- which resolves to several def_ids in the same ada space.
-- e.g. dependents.show ("directory.naming.resolve'spec");
-- this will run the dependents analysis over all of the def_ids
-- resolved to by the naming expression.
-- one can also place marks on a group of def_ids in the same space
-- and invoke the command as:
-- dependents.show ("<marks>", options => "count=n");
-- where n is the number of marks to be taken off the mark_stack.
-- this will run the dependents analysis over all the def_ids
-- removed from the mark_stack.
--
-- the line(s) of a dependents display before the first blank line
-- denote the main_item(s).
-- the succeeding nonblank lines denote dependents.
--
-- the display argument determines whether unit level or item
-- level dependents are shown and how the information is presented.
-- (see below).
--
-- the level argument determines what level of dependence should be
-- shown initially. this can be changed after the display is brought up.
--
-- limit, if not defaulted, restricts the displayed dependents to
-- those that occur within objects specified by the limit
-- naming expression.
--
-- if global = false then only uses within the unit containing the
-- identifier resolved to will be shown (by underlining them).
--
---------------------------------------------------------------------------
--
-- explanation of the display kinds.
--
-- these different displays can be produced using the elide/expand
-- and sort commands. the display kinds are ordered so that moving
-- through them produces more specific information about the dependents.
--
-- Subsystems
-- full names of subsystems containing views with dependents.
--
-- Views
-- full names of views containing units with dependents.
--
-- Units
-- names of compilation units that contain dependents or are
-- themselves dependents.
-- see below for how to control how compilation unit names
-- are displayed.
--
-- Parents
-- names of ada program units containing dependents.
-- these will be the names of procedures, functions, packages,
-- tasks, generics, or record_types which immediately contain
-- dependent items.
-- this display lists the parent name followed by the unit name.
-- example:
--
-- set_value STACK_MANAGER'BODY !L1.L2.L3
-- get_value STACK_MANAGER'BODY !L1.L2.L3
-- add_element TEST'BODY !U1.U2
--
-- this says that program unit set_value contains a dependent
-- as does get_value and add_element.
--
-- in the case where the parent ada program unit is itself a
-- compilation unit or in the case where an entire compilation
-- unit is a dependent, the parent name field will be given as
-- *comp_unit*.
--
-- Item_Kinds
-- this display shows the kind of the nearest ada construct
-- enclosing a dependent, followed by the parent name.
-- the constructs will be from the categories statements,
-- declarations, etc.
-- there will be one line per dependent construct.
-- example:
--
-- assign set_value STACK_MANAGER'BODY !L1.L2.L3
-- if get_value STACK_MANAGER'BODY !L1.L2.L3
-- call add_element TEST'BODY !U1.U2
--
-- the first line says that an assignment statement in the
-- program unit set_value which is in the compilation unit
-- !L1.L2.L3.STACK_MANAGER'BODY has a dependent within it.
--
-- if the display level is demote_closure (see below) then
-- the construct shown will be the nearest enclosing demotable
-- item containing dependents.
--
-- sometimes an item level dependent will be an entire comp unit.
--
-- Units_And_Kinds
-- this display shows the same information as the previous one
-- but it presents each compilation unit first, followed by its
-- list of dependents. with a blank line between each comp unit.
-- example:
--
-- STACK_MANAGER'BODY !L1.L2.L3
-- assign set_value
-- if get_value
--
-- TEST'BODY !U1.U2
-- call add_element
--
-- Units_And_Items
-- this display is similar to the previous one in that it
-- shows the name of each compilation unit preceded by a blank
-- line; but rather than showing just the name of the kind of
-- construct which has a dependent, it shows a compressed one
-- line form of the text of the ada construct.
-- the place within the construct that has a reference to the
-- main_item will be underlined. (not shown here).
-- example:
--
-- STACK_MANAGER'BODY !L1.L2.L3
-- Abc := Def (3);
-- if Def (5) then
--
-- TEST'BODY !U1.U2
-- Foo (Stack_Manager.Def (4));
--
-- Parents_And_Items
-- this display is similar to the previous one with the change that
-- the one line form of the text of an ada construct is replaced
-- by a group of lines of the form
--
-- parent_kind parent_name
-- line 1 of ada text
-- ...
-- line n of ada text.
--
-- example:
--
-- STACK_MANAGER'BODY !L1.L2.L3
-- proc_body set_value
-- Abc := Def (3);
--
-- func_body get_value
-- if Def (5) then
-- Mumble;
-- end if;
--
-- TEST'BODY !U1.U2
-- proc_body add_element
-- Foo (Stack_Manager.Def (4));
--
---------------------------------------------------------------------------
--
-- compilation unit and library names are always shown in upper case.
-- parent names and item kinds are shown in lower case.
--
-- full names of compilation units can be displayed either
-- with the library unit name first, some space, and then the
-- library name; or as the standard pathname with library name
-- first, followed immediately by the library unit name.
--
-- there is an option to control which format is used.
-- this option is either set when the command is invoked;
-- or if it is not explicitly given in the option string,
-- the session switch:
-- Dependents_In_Order_Pathnames is checked.
-- furthermore after a display has been brought up the value of this
-- option can be changed by the In_Order command
--
-- if pathnames are being shown in transposed order there is an option
-- to control whether library names are shown.
-- there is also a corresponding session switch called:
-- Dependents_Show_Library and a command called Libraries.
--
-- there is an option to control whether compilation states are
-- shown for the units or items in a display.
-- there is also a corresponding session switch called:
-- Dependents_Show_Unit_State and a command called States.
-- compilation states will be shown as a single letter from
-- S, I, C, preceding the unit or item.
--
-- there is a session switch called
-- Dependents_Delta0_Compatibility (which defaults to true)
-- which if set implies in_order pathnames and controls the
-- format of the first line.
-- this switch also controls the contents of the first line
-- in obsolescence windows.
--
---------------------------------------------------------------------------
-- dependents_level meanings:
--
-- unfiltered
-- dependent units directly from the ddb are shown without
-- checking if they actually have references to the main_item.
-- sometimes more units will be listed than those that actually
-- have dependents. this can occur in the case of a main_item
-- which is overloadable; or in the case of a unit which once had
-- a dependent but no longer does. also the unit containing
-- the main_item is always listed as a potential dependent.
-- this display is only possible for unit displays.
-- if an elision command is given to change the display to an
-- item display the units will be automatically filtered.
-- also if the main_item is a record field the initial display
-- will always be filtered.
--
-- immediate
-- units are checked for references.
-- only units which actually have dependents are shown.
--
-- reference_closure
-- in addition to showing immediate references:
--
-- * for types, packages, subprograms, exceptions
-- references to renames and derivations are included.
-- * for items in generic specs - references to the corresponding
-- id in instantiations of that generic are shown.
-- * for subprogram parameters - parameters passed in calls
-- are shown.
-- * for generic parameters - actual parameters passed to the
-- parameter in instantiations are shown.
--
-- also, for any main_item which can occur as a default value for a
-- subprogram parameter, any call which uses the default will be
-- marked as a dependent of the main_item.
--
-- demote_closure
-- units or items which have to be demoted to demote the
-- main_item are shown.
--
-- for the demote/promote commands when region selections are used,
-- which display kind is being shown, determines whether whole
-- compilation units are demoted/promoted or individual items
-- within compilation units are demoted/promoted.
-- if the display kind is Units then comp units will be
-- demoted/promoted. otherwise items will be demoted/promoted.
-- (even though comp_unit names occupy a separate line in
-- certain elision levels and may be included in the selection).
--
-- when item level demote_closure is being shown, contiguous
-- dependent items will be merged into one line in the display.
-- (and will be demoted as a group).
--
-- scenario for editing the main_item:
--
-- * bring up an initial unit display.
-- * if you wish to demote item level dependents.
-- create a command window and type: items;
-- this will change the display kind to item level dependents.
-- * press the complete key.
-- this will change the display to demote_closure
-- * select the entire display.
-- * press the demote key.
-- this will demote all dependents and the main_item to source.
-- * to edit the demoted main_item or any of the demoted dependents
-- put the cursor on the line which represents that item or unit
-- and press the edit key.
-- this will bring up a window on the unit or item.
-- * make any changes, committing the windows.
-- when all changes have been made, return to dependents menu and
-- * select the display.
-- * press the promote key.
-- this will promote all source units or items in the display
-- to installed.
-- if any items fail to install they can be fixed and promoted
-- again with single line selections or if a region is selected and
-- it contains a mix of both source and installed items only the
-- source items will be promoted.
--
-- remember that certain kinds of items which one can produce an xref of
-- cannot be incrementally edited. these include enumeration literals,
-- record fields, subprogram and generic parameters.
--
---------------------------------------------------------------------------
--
-- options on show command.
--
-- IN_PLACE
-- brings up the window on top of the current window.
-- default is false.
--
-- NEW_WINDOW
-- always create a new window for this display.
-- default is to reuse an existing dependents window.
-- previous contents of a reused dependents window can be
-- revisited using object undo/redo or the Contents command.
--
-- MENU_ALWAYS
-- if menu_always is false (the default) and the only dependents
-- are within the same unit as the main_item then no window is
-- brought up and the dependents are underlined.
-- if menu_always is true then a window is always brought up
-- if there are any dependents.
--
-- COUNT=<integer>
-- count > 1 specifies that count-many contiguous def_ids
-- starting at the one selected are to have their dependents
-- shown. default is 1.
--
-- STATES
-- show unit/item compilation states, default is false.
--
-- IN_ORDER
-- show comp unit names with library first, default is false
--
-- LIBRARIES
-- show library names, default is true.
--
-- SOURCE
-- default is false.
-- search source units which are registered in the ddb
-- for dependents. also search source bodies/subunits of
-- units whose specs/bodies have been checked.
-- checking for dependents within source units will not in
-- general be exact. in the absence of semantic information
-- a heuristic approach is taken which in most cases (if the
-- identifier of the main_item is distinctive) will find
-- the set of dependents (and possibly some other items which
-- aren't actually dependents).
--
-- CHECK=<naming_expression>
-- check any source units in the naming expression for references.
--
-- RESTRICT = <argument>
-- see Restrict command below for legal argument values.
--
---------------------------------------------------------------------------
--
-- common commands which can be applied when the cursor is in a
-- dependents window.
--
-- * common.definition
-- visit the entity denoted by the line the cursor is on.
-- if the line denotes a compilation unit or parent with dependents
-- then they will be underlined and the cursor positioned to the
-- first of them.
-- if line denotes an item then the cursor will be positioned
-- on that item, which will be selected.
-- if the cursor line has a parent or unit name in it and the cursor
-- has been moved onto that parent or unit name then that parent
-- or unit will be visited.
-- if the cursor line is showing full ada text and the cursor has been
-- moved to a using identifier the definition of the using identifier
-- will be visited.
-- the node which would be visited by definition is the node which
-- this editor returns when name resolution of <CURSOR> is run
-- against it. so if while reading an xref display one wants to
-- run another xref off an item in the display this can be done
-- by positioning the cursor on the desired item in the xref
-- display and invoking the xref command.
--
-- * common.edit:
-- (demote if necessary and possible and) edit the item
-- of the line the cursor is on.
-- if the item is in the installed (or greater) state it
-- must be selected.
--
-- * common.enclosing:
-- find the image of the object for which these items are dependents.
--
-- * common.demote:
-- demote the entities corresponding to the set of lines selected.
-- if the entire image is selected the goal state will be source.
-- otherwise it will be the predecessor of the current state of the
-- entity.
--
-- * common.promote:
-- promote the entitites corresponding to the set of lines selected.
--
-- * common.format
-- if display is unfiltered, change it to immediate.
--
-- * common.semanticize
-- if display is unfiltered, change it to immediate.
-- if display is immediate, change it to reference_closure.
--
-- * common.complete
-- change display to demote_closure.
--
-- * common.undo and redo
-- move thru the images in this window.
--
-- * common.revert:
-- recompute the current dependents set of the main_item.
--
-- * common.object.delete
-- destroy the item selected.
--
-- * common.expand and elide
-- relative motion among the display kinds.
-- repeat count > 1 moves multiple steps.
-- if there is no selection the entire display is moved to a
-- new elision level.
-- if there is a selection, only the selected entity will be
-- expanded/elided.
-- if a selected item is at the final elision level and expand
-- is typed, the display will be replaced by the ada text
-- for an enclosing construct of that item.
-- this will continue with further expands until the program unit
-- containing the item fills the display.
-- if the display is showing just an expanded_item,
-- elide will transition the display back to the full dependents
-- display.
--
-- * common.sort_image
-- absolute addressing of display kinds based on format parameter.
-- 1 = subsystems, 2 = views, 3 = units, 4 = parents, 5 = item_kinds,
-- 6 = units_and_kinds, 7 = units_and_items, 8 = parents_and_items.
-- if a display has some lines at a different elision level from
-- the entire display level, 0 as a sort prefix will change all
-- lines to the current display level.
--
-- * common.object.child
-- if no selection, select the item under the cursor, otherwise
-- expand the item under the cursor.
-- if the entire display is showing an expanded_item, this command
-- will not require a selection to expand.
--
-- * common.object.next/previous
-- if no selection, select the item under the cursor. If there is a
-- selection, move it to the next/previous item.
-- * common.object.parent
-- if no selection, select the item under the cursor. If the item is
-- selected, expand the selection.
--
---------------------------------------------------------------------------
---------------------------------------------------------------------------
--
package Commands is
-- commands which can be run off of a dependents window
procedure Items;
-- change the display to an item level display
procedure Units;
-- change the display to a unit level display
procedure Parents;
-- change the display to a parents display
procedure Immediate;
-- change the display to an immediate dependents display
----------------------------------------------------------------------
procedure Libraries (Show : Boolean := True);
-- control whether library names are displayed
procedure States (Show : Boolean := True);
-- control whether unit states are displayed
procedure In_Order (Value : Boolean := True);
-- control whether comp unit names have library names shown first
procedure Contents;
-- show a table of contents for the images in this window.
---------------------------------------------------------------------
procedure Keep;
-- if there is a selection then remove any units not selected
-- from the display. it there is no selection remove all but the
-- line the cursor is on.
procedure Remove;
-- it there is a selection then remove selected units from the
-- display. if there is no selection remove the unit the cursor is on.
procedure Show_All;
-- redisplay any units removed by keep, or remove.
procedure Limit (To : String := "<ACTIVITY>");
-- limit the set of units displayed.
procedure Unlimit;
-- show any units that were removed by a limit command
------------------------------------------------------------
procedure Uncode;
-- demote all coded units selected in the display to installed
procedure Source;
-- demote all units selected in the display to source
procedure Installed;
-- promote all units selected in the display to installed
procedure Coded;
-- promote all units selected in the display to coded
procedure Remake;
-- promote all units selected in the display to their state when
-- first displayed.
----------------------------------------------------------------------
procedure Look_Through (Name : String := "<ACTIVITY>";
Limit : Boolean := False);
-- the main_item must be in a spec.
--
-- if name is an activity:
-- if the main_item is in a load_view find its corresponding
-- id in the spec view implied by the activity and
-- display that id's dependents.
-- if limit is true then limit the dependents to views in the
-- activity.
--
-- if the main_item is in a spec_view find its corresponding
-- id in the load view implied by the activity and
-- display that id's dependents.
-- limit is not relevant is this case.
--
-- if name is a view or world:
-- find the corresponding id for the main_item in the given
-- view or world and display that id's dependents.
procedure Succ (Repeat : Integer := 1);
-- reconstruct the display with the next def_id after the
-- current main id
procedure Pred (Repeat : Integer := 1);
-- reconstruct the display with the prior def_id to the current
-- main id
procedure Diana_Edit;
-- run diana_edit on the node the cursor is on.
------------------------------------------------------------
procedure Restrict (To : String);
-- restrict the display to a particular kind of reference.
-- the argument can be a sequence of one or more of the following
-- restriction kinds:
--
-- internal - show only uses of the main_item (which must
-- be in the visible part of a package)
-- which are within that package
-- external - show only uses of the main_item (which must
-- be in the visible part of a package)
-- which are outside of that package
-- defaulted - show calls where a parameter is defaulted.
-- nondefaulted - show calls where a parameter isn't defaulted.
-- used_ops - show only operators made visible by a use clause
-- used_ids - show only non operators made visible by a
-- use clause
-- closure - show only references which are in the
-- reference_closure and not in the immediate set.
-- writes - show places where an object is assigned to.
--
-- variables, constants, numbers, exceptions, types,
-- subtypes, generics, tasks, parameters, withs, uses,
-- subprograms, specs, bodies, renamings, instantiations,
-- compound_types, record_types, array_types,
-- derived_types, access_types, numeric_types, enum_types,
-- stmts, alternatives, handlers, accepts, assigns,
-- calls, loops, ifs, cases, returns, raises, selects,
-- aggregates, allocators, relationals, conversions,
-- pragmas
--
-- any unique prefix of a restriction kind can be given.
-- several restrictions can be given in one command by
-- separating them by a space. e.g.
-- restrict ("external alternatives"); or
-- restrict ("ext alt");
-- this means only show case alternatives which are external to
-- the package containing the main_item.
--
-- a restriction kind can be negated by prefixing it with
-- a not sign (~). e.g.
-- restrict ("~withs ~parameters);
-- this means only show contructs that aren't with clauses and
-- aren't parameter declarations.
--
-- restrict ("?"); displays the names of all restriction kinds.
procedure Unrestrict;
-- show any items that were removed by a restrict command
------------------------------------------------------------
procedure Display (Constructs : String);
-- find transitive uses of a main_item which is a type
-- or record field in a particular kind of construct.
-- possible values of the argument are:
-- aggregates,
-- allocators,
-- assigns,
-- cases,
-- creates,
-- assign_closure,
-- create_closure.
--
-- any unique prefix of the argument name can be given.
-- several arguments can be given by separating them by spaces.
-- e.g. display ("creates create_closure");
--
-- aggregates shows all aggregates over the main_item if it is
-- a compound type (record, array);
-- if the main_item is a discrete type it shows array aggregates
-- whose index type is the main_item.
--
-- allocators shows all allocators whose result type is the main_item.
--
-- assigns show assigment statements where an object of the type
-- is assigned. in the case of compound types it also shows where an
-- assignment to a subcomponent is done.
--
-- cases shows all cases statements over the main_item
-- (which must be discrete type).
--
-- creates shows places where a variable or constant of the type
-- is declared; or where an allocator of an object of the type
-- is done.
--
-- assign_closure, create_closure run the analysis over compound types
-- which contain the main_item as a subcomponent.
-- object undo will change the display back to a regular
-- dependents display.
--
------------------------------------------------------------
procedure Replace (Target : String := "";
Replacement : String := "";
Wildcard : Boolean := False;
Main_Also : Boolean := True);
-- edit each source item in the display and do a search/replace
-- of the target with replacement.
------------------------------------------------------------
function Names return String;
-- return a string of the form [u1,u2,...un]
-- where ui is the ith unit showing in the display
-- or in the selection if there is one.
---------------------------------------------------------------------------
procedure Delete;
-- for a window with a set of images within it,
-- remove this image from the set and redraw the window
-- with the prior one in the history.
---------------------------------------------------------------------------
procedure Subunit_Levels (Number : Integer := Integer'Last);
-- number of parent library unit names to show for the non in_order
-- unit name field.
-- a value of 1 means show the name of the innermost enclosing
-- subunit only (if the enclosing unit is a library unit it
-- will always be shown).
-- a value of 2 means show the names of at most 2 of the innermost
-- enclosing subunits and so on.
-- a value of integer'last causes full names to be shown again.
-- a value of 0 means don't show subunit names just show the
-- library unit name.
-- a value of integer'first means don't show the unit name field
-- at all in the items and parents elision levels.
-- a value of -x means remove abs (x) names from the front of
-- a name.
procedure Parent_Levels (Number : Integer := Integer'Last);
-- number of parent names to show in the parent name field.
procedure Unit_Length (Max : Integer := Integer'Last);
-- max length name to display in the unit name field.
procedure Parent_Length (Max : Integer := Integer'Last);
-- max length name to display in the parent name field.
end Commands;
---------------------------------------------------------------------------
---------------------------------------------------------------------------
procedure Window (Kind : String := "xref";
Restart : Boolean := True;
In_Place : Boolean := False;
Wrap : Boolean := False);
-- make visible a menu window.
-- choices for kind include:
-- xref, find, unused, errors, holds, ada_menu, menu.
-- if restart = true bring up the most recently created.
-- if there are multiple windows of the kind specified and
-- restart = false then cycle thru the windows with successive calls.
-- when at last window, wrap controls whether to go back to first.
---------------------------------------------------------------------------
procedure Find (Pattern : String := "";
Units : String := "$@?";
Display : Display_Kind := Dependents.Units_And_Kinds;
Wildcard : Boolean := False;
Ignore_Case : Boolean := True;
Options : String := "");
-- search the ada units specified by units for the given pattern.
-- any units with occurences will be displayed in a menu.
procedure Unused (In_Units : String := "<CURSOR>";
Check_Other_Units : Boolean := False;
Display : Display_Kind := Dependents.Units_And_Kinds;
Options : String := "");
-- show the declarations in units that are not referenced.
-- any units with unused declarations will be displayed in a menu.
-- for find and unused the following are allowed.
--
-- options:
-- in_place, new_window, restrict, libraries, states, in_order,
-- menu_always.
--
-- common commands:
-- definition, edit, enclosing, demote, promote, delete,
-- elide, expand, sort, next, previous, parent, child, undo, redo,
-- revert (for unused only).
--
-- dependents commands:
-- libraries, in_order, states, items, units, parents,
-- limit, unlimit, restrict, unrestrict, keep, remove, show_all,
-- contents, replace, names, diana_edit,
-- uncode, source, installed, coded, remake.
--
---------------------------------------------------------------------------
procedure Menu (Units : String;
First_Line : String := "";
Name_Field : String := "";
Options : String := "");
-- display a menu of the units resolved to by units.
--
-- options allowed:
-- in_place, new_window, libraries, states, in_order.
--
-- common commands:
-- definition, edit, enclosing, demote, promote, parent, child,
-- next, previous, undo, redo
--
-- dependents commands:
-- replace, limit, unlimit, keep, remove, show_all, contents,
-- in_order, states, libraries, uncode, source, installed, coded, remake.
---------------------------------------------------------------------------
procedure Errors (Units : String := "<CURSOR>"; Options : String := "");
-- display a menu of the error messages in the units specified.
-- if <cursor> is given and the cursor is on a node with error messages
-- then just display the messages on that node.
--
-- if an error message refers to another node that node can be accessed
-- from the menu by moving the cursor to the end of the error message
-- text and doing definition.
--
-- options allowed:
-- in_place, new_window, in_order, libraries, menu_always,
-- kind =
-- all_errors - the default, show all messages.
-- warnings - show only warnings messages
-- errors - show only error messages, no warnings.
--
-- if menu_always is false then no menu will be brought up. the
-- error nodes will be underlined in the ada unit.
--
---------------------------------------------------------------------------
procedure Holds (Count : Integer := 10; Options : String := "");
-- show a menu of the items on the hold stack.
pragma Subsystem (Object_Editor);
pragma Module_Name (4, 2227);
end Dependents;package Diana_Tree is
procedure Ada_Edit (Name : String := "<IMAGE>");
pragma Subsystem (Command);
pragma Module_Name (4, 2211);
end Diana_Tree;package Disk_Space is
type Acceptable is (Any_Space, Any_Permanent_Space,
Committed_Permanent_Spaces,
Undeleted_Committed_Permanent_Spaces);
type Traversals is (Poly_File_Space, Directory_Space, Eedb_Space,
Constant_Space, Moribund_Space, Backup_Database_Space);
type Traversing is array (Traversals) of Boolean;
All_Traversals : constant Traversing := Traversing'(others => True);
Directory_Only : constant Traversing :=
Traversing'(Directory_Space => True, others => False);
No_Traversals : constant Traversing := Traversing'(others => False);
-- Possible decodings of a space.
-- Class (R1000_Native_Code .. R1000_Cross_Code) are instruction spaces.
-- Class (R1000_Import) is any import space.
-- Class (Diana_Tree .. Other) are module spaces.
-- Class (Diana_Tree .. Seg_Heap_Other) are all segmented heaps.
-- Class (Poly_Text .. Poly_Other) are all Polymorphic_Io creations.
-- Class (Backup_Master .. Backup_Tape) are Backup database spaces.
-- Class (Garbage) is a garbage collected (by the Disk_Cleaner) space.
type Class is (R1000_Native_Code, R1000_Cross_Code, R1000_Import,
Diana_Tree, Text_File, Image, Link_Pack,
Poly_Text, Poly_Object_Id, Poly_State, Poly_Other,
Backup_Id, Backup_Backup, Backup_Processor,
Backup_Disk, Backup_Tape, Backup_Master,
Configuration, Seg_Heap_Other, Garbage, Other);
type Classes is array (Class) of Boolean;
All_Classes : constant Classes := Classes'(others => True);
Module_Classes : constant Classes := Classes'(R1000_Native_Code => False,
R1000_Cross_Code => False,
R1000_Import => False,
others => True);
Matching_Class : constant Classes := Classes'(others => False);
Unknown_Classes : constant Classes := Classes'(Poly_Other => True,
Seg_Heap_Other => True,
Other => True,
others => False);
type Space_Kind is (Instruction, Import, Module);
Data : constant Space_Kind := Module;
-- Examine_Spaces locates all spaces known to the kernel and discards
-- any that are either unacceptable or can be reached through one of
-- the traversals.
-- The Summarize booleans cause listings of the space counts / sizes to
-- be printed. List_Lost causes Space_Information for the unreachable
-- spaces to be printed.
procedure Examine_Spaces
(Examine : Traversing := Disk_Space.All_Traversals;
Filter : Acceptable :=
Disk_Space.Undeleted_Committed_Permanent_Spaces;
Permit : Classes := Disk_Space.All_Classes;
Summarize_All : Boolean := False;
Summarize_Lost : Boolean := True;
List_Lost : Boolean := False;
Verbose : Boolean := True);
-- Attempts to find the name of the object which contains the space
-- specified, and prints that name. If the null space is specified
-- (the default values), then the names of all spaces are printed.
-- If the directory system is being searched, Vol_Hint /= 0 will
-- cause the search to attempt to avoid looking on the wrong volume.
-- Root_Name specifies where the directory system search should begin.
procedure Name_Space (Vp : Natural := 0;
Kind : Space_Kind := Disk_Space.Instruction;
Segment : Natural := 0;
Vol_Hint : Natural := 0;
Root_Name : String := "!";
Search : Traversing := Disk_Space.All_Traversals;
Verbose : Boolean := True);
-- Searches just as with Name_Space, but will search for any space
-- with the same Family_Id as the space specified.
procedure Name_Family (Vp : Natural := 0;
Kind : Space_Kind := Disk_Space.Instruction;
Segment : Natural := 0;
Vol_Hint : Natural := 0;
Root_Name : String := "!";
Search : Traversing := Disk_Space.All_Traversals;
Verbose : Boolean := True);
-- Interpret page 0 of the data segment in various ways.
-- Instruction spaces don't have data segments, so only useful for Modules.
procedure Decode_Space (Vp : Natural := 0;
Kind : Space_Kind := Disk_Space.Module;
Segment : Natural := 0;
Match : Classes := Disk_Space.Matching_Class;
Verbose : Boolean := True);
-- *********************************************************************
-- Do not use the following commands unless you know what you are doing.
-- *********************************************************************
type Mark_Type is new Natural range 0 .. 1023;
type Volume_Number is new Natural range 0 .. 31;
type Block_Number is new Natural range 0 .. 2 ** 24 - 1;
type Usage_Array_Type is array (Mark_Type) of Natural;
type Vol_Bit_Map_Array is array (Block_Number range <>) of Boolean;
type Vol_Usage_Array is array (Block_Number range <>) of Mark_Type;
type System_Usage_Array is
array (Volume_Number range <>) of Usage_Array_Type;
Unable_To_Acquire_Backup_Lock : exception;
Garbage_Collection_Is_Running : exception;
function First_Volume return Volume_Number;
function Last_Volume return Volume_Number;
function Find_Storage_Consumed return System_Usage_Array;
procedure Clean_Cache;
function Get_Bit_Map (Volume : Volume_Number) return Vol_Bit_Map_Array;
function Find_Current_Usage (Volume : Volume_Number) return Vol_Usage_Array;
pragma Subsystem (Commands);
pragma Module_Name (4, 3935);
end Disk_Space;package Editor is
package Cursor is
procedure Down (Repeat : Integer := 1);
procedure Left (Repeat : Integer := 1);
procedure Right (Repeat : Integer := 1);
procedure Up (Repeat : Integer := 1);
-- Quarter-plane motion
procedure Forward (Repeat : Integer := 1);
procedure Backward (Repeat : Integer := 1);
-- Stream motion, end of line N adjacent to beginning of line N+1
procedure Next (Repeat : Integer := 1;
Prompt : Boolean := True;
Underline : Boolean := True);
procedure Previous (Repeat : Integer := 1;
Prompt : Boolean := True;
Underline : Boolean := True);
-- Position the cursor at the next (previous) closest prompt or
-- underline. Prompt (Underline) false indicates not to look
-- for the next Prompt (Underline). Both false does nothing
end Cursor;
package Search is
procedure Previous (Target : String := ""; Wildcard : Boolean := False);
procedure Next (Target : String := ""; Wildcard : Boolean := False);
procedure Replace_Previous (Target : String := "";
Replacement : String := "";
Repeat : Integer := 1;
Wildcard : Boolean := False);
procedure Replace_Next (Target : String := "";
Replacement : String := "";
Repeat : Integer := 1;
Wildcard : Boolean := False);
end Search;
package Char is
procedure Capitalize (Repeat : Integer := 1);
procedure Delete_Backward (Repeat : Integer := 1);
procedure Delete_Forward (Repeat : Integer := 1);
-- Stream deletion end of line N is adjacent to beginning
-- of line N+1
procedure Delete_Next (Repeat : Integer := 1);
procedure Delete_Previous (Repeat : Integer := 1);
-- Quarter-plane deletion
procedure Delete_Spaces (Remaining : Natural := 1);
-- Delete spaces surrounding the cursor, leaving remaining spaces
procedure Insert_String (Value : String);
procedure Insert_Character (Repeat : Integer := 1; Value : Character);
procedure Lower_Case (Repeat : Integer := 1);
procedure Quote;
procedure Tab_Backward (Repeat : Integer := 1);
procedure Tab_Forward (Repeat : Integer := 1);
procedure Tab_To_Comment;
-- Tab to the comment column and insert comment marks
procedure Transpose (Offset : Integer := 1);
procedure Upper_Case (Repeat : Integer := 1);
end Char;
package Line is
procedure Beginning_Of (Offset : Natural := 0);
procedure Capitalize (Repeat : Integer := 1);
procedure Center (Right_Margin : Natural := 0);
procedure Copy (Repeat : Integer := 1);
procedure Delete (Repeat : Integer := 1);
procedure Delete_Backward (Repeat : Integer := 1);
procedure Delete_Forward (Repeat : Integer := 1);
procedure End_Of (Offset : Natural := 0);
procedure Insert (Repeat : Integer := 1);
procedure Indent (Repeat : Integer := 1);
procedure Join (Repeat : Integer := 1);
procedure Lower_Case (Repeat : Integer := 1);
procedure Open (Repeat : Integer := 1);
procedure Transpose (Offset : Integer := 1);
procedure Upper_Case (Repeat : Integer := 1);
procedure Next (Repeat : Integer := 1) renames Cursor.Down;
procedure Previous (Repeat : Integer := 1) renames Cursor.Up;
end Line;
package Word is
procedure Beginning_Of;
procedure Breaks (Break_Set : String := "";
Are_Delimiters : Boolean := True);
procedure Capitalize (Repeat : Integer := 1);
procedure End_Of;
procedure Delete (Repeat : Integer := 1);
procedure Delete_Backward (Repeat : Integer := 1);
procedure Delete_Forward (Repeat : Integer := 1);
procedure Lower_Case (Repeat : Integer := 1);
procedure Next (Repeat : Integer := 1);
procedure Previous (Repeat : Integer := 1);
procedure Transpose (Offset : Integer := 1);
procedure Upper_Case (Repeat : Integer := 1);
end Word;
package Image is
-- repeat = 0 scrolls one page
procedure Up (Repeat : Integer := 0);
procedure Down (Repeat : Integer := 0);
procedure Left (Repeat : Integer := 0);
procedure Right (Repeat : Integer := 0);
procedure Find (Name : String);
procedure Beginning_Of (Offset : Natural := 0);
procedure End_Of (Offset : Natural := 0);
end Image;
-- Many of the following packages implement a "stack" discipline. For
-- these packages, the following operations are supported:
--
-- Copy_Top Push a copy of the top of stack
-- Delete_Top Delete the top element from the stack
-- Next Use the next value on the stack
-- Previous Use the previous value on the stack
-- Push Put the appropriate item on the stack
-- Rotate Rotate the stack; top becomes the bottom; value not
-- used
-- Swap Interchange the top and next to top items; value not
-- used
-- Top Use the top value on the stack
package Screen is
procedure Down (Repeat : Integer := 1);
procedure Left (Repeat : Integer := 1);
procedure Right (Repeat : Integer := 1);
procedure Up (Repeat : Integer := 1);
procedure Dump (To_File : String := ">>NAME<<");
procedure Redraw;
procedure Clear;
-- Screen stack operations
procedure Copy_Top;
procedure Delete_Top;
procedure Next (Repeat : Integer := 1);
procedure Previous (Repeat : Integer := 1);
procedure Push (Repeat : Integer := 1);
procedure Rotate (Repeat : Integer := 1);
procedure Swap;
procedure Top;
-- Set terminal lines and columns for this session.
-- Changes take effect at Set_Lines calls.
procedure Set_Columns (Columns : Natural);
procedure Set_Lines (Lines : Natural);
end Screen;
package Window is
procedure Beginning_Of (Offset : Natural := 0);
procedure Child (Repeat : Integer := 1);
procedure Copy;
procedure Delete;
procedure Demote;
procedure Directory;
procedure End_Of (Offset : Natural := 0);
procedure Expand (Lines : Integer := 4);
procedure Focus;
procedure Frames (Maximum : Positive);
procedure Join (Repeat : Integer := 1);
procedure Next (Repeat : Integer := 1);
procedure Parent (Repeat : Integer := 1);
procedure Previous (Repeat : Integer := 1);
procedure Promote;
procedure Transpose (Offset : Integer := 1);
end Window;
package Macro is
procedure Start;
procedure Finish;
-- Start/Finish the definition of a keyboard macro
procedure Execute (Repeat : Integer := 1; Prior : Natural := 0);
-- Execute the current keyboard macro Repeat times. If Prior /= 0
-- execute the macro with that number.
procedure Bind (Key : String := "");
-- bind the current macro to the key name given, e.g. F1, M_F1.
procedure Save (Expanded : Boolean := False);
-- Save the current macro state in the user macro file.
-- Expanded causes the file string to be saved in text form.
procedure Restore;
-- Recreate macro state from the user macro file.
end Macro;
package Hold_Stack is
procedure Copy_Top;
procedure Delete_Top;
procedure Next (Repeat : Integer := 1);
procedure Previous (Repeat : Integer := 1);
procedure Push (Repeat : Integer := 1);
procedure Rotate (Repeat : Integer := 1);
procedure Swap;
procedure Top;
end Hold_Stack;
package Mark is
procedure Copy_Top;
procedure Delete_Top;
procedure Next (Repeat : Integer := 1);
procedure Previous (Repeat : Integer := 1);
procedure Push (Repeat : Integer := 1);
procedure Rotate (Repeat : Integer := 1);
procedure Swap;
procedure Top;
end Mark;
package Region is
procedure Beginning_Of;
procedure Capitalize;
procedure Comment;
-- Add comment marks to the beginning of the lines in the region
procedure Copy;
procedure Delete;
procedure End_Of;
procedure Fill (Column : Natural := 0; Leading : String := "");
procedure Finish;
procedure Justify (Column : Natural := 0; Leading : String := "");
-- 0 argument uses default fill column
procedure Lower_Case;
procedure Move;
procedure Off;
procedure On;
procedure Start;
procedure Uncomment;
procedure Upper_Case;
end Region;
package Set is
procedure Insert_Mode (On : Boolean := True);
procedure Fill_Mode (On : Boolean := True);
procedure Fill_Column (Column : Positive := 72);
procedure Designation_Off;
procedure Input_From (File_Name : String := "<SELECTION>");
procedure Input_Logging_To (File_Name : String := ">>Name<<");
procedure Input_Logging_Off;
procedure Tab_Off (Column : Positive);
procedure Tab_On (Column : Positive);
procedure Tab_Width (Size : Positive := 4);
-- Only to be bound on keys
procedure Argument_Prefix;
procedure Argument_Digit (Argument : Integer := 1);
procedure Argument_Minus;
end Set;
package Key is
procedure Define (Key_Name : String := ">>KEY NAME, e.g. CM_F1<<";
Command_Name : String := ">>COMMAND NAME<<";
Prompt : Boolean := False);
procedure Name (Key_Code : String := "");
procedure Save;
procedure Prompt (Key_Code : String := "");
end Key;
procedure Quit (Ignore_Changes : Boolean := False);
procedure Alert;
procedure Noop;
pragma Subsystem (Command);
pragma Module_Name (4, 2205);
end Editor;package File_Utilities is
subtype Name is String;
Current_Output : constant Name := "";
procedure Difference (File_1 : Name := "<REGION>";
File_2 : Name := "<IMAGE>";
Result : Name := "";
Compressed_Output : Boolean := False;
Subobjects : Boolean := False);
-- Find differences between two versions of an object.
-- If Subobjects is True, subobjects are compared as well.
-- Compressed output omits lines that are the same in both objects.
-- Non-compressed output shows every line from both objects,
-- only showing common lines once.
procedure Merge (Original : Name := "";
File_1 : Name := "";
File_2 : Name := "";
Result : Name := "");
-- merge two variants of the same object into new version with all changes
-- Result defaults to Current_Output = ""
procedure Strip (Source : Name := "<SELECTION>"; Target : Name := "");
-- take the output of Merge or Difference and create a clean file
procedure Compare (File_1 : Name := "<REGION>";
File_2 : Name := "<IMAGE>";
Subobjects : Boolean := False;
Ignore_Case : Boolean := False;
Options : String := "");
-- find the first difference between two objects
-- Subobjects=true causes subunits or units in a library to be compared
-- as well as the named units.
-- Ignore_Case=true causes upper and lower case to be treated as
-- equivalent.
-- Options include: Ignore_Blank_Lines: causes only on-blank lines
-- to be considered in the compare
-- File_2_Has_Wildcards: Interpret characters in File_2
-- as possible Wildcards. Wildcard
-- characters include:
-- ^ - negate next char
-- ? - match any char
-- % - match any Ada ident char
-- $ - match any Ada delimiter
-- \ - quotes next char
-- { - beginning of line
-- } - end of line
-- [ - start of class
-- ] - end of class
-- * - zero or more of prev item
--
-- Use of Ignore_Case or Ignore_Blank_Lines slows the compare operation
-- moderately with respect to a straight compare. File_2_Has_Wildcards
-- slows the compare dramatically and should only be used if you have
-- a lot of time to wait. The wildcard compare is conducted on a line-
-- by-line basis.
function Equal (File_1 : Name := "<REGION>";
File_2 : Name := "<IMAGE>";
Subobjects : Boolean := False;
Ignore_Case : Boolean := False;
Options : String := "") return Boolean;
-- Indicates whether the two files are the same
-- See notes under Compare, above.
procedure Find (Pattern : String := "";
File : Name := "<IMAGE>";
Wildcards : Boolean := False;
Ignore_Case : Boolean := True;
Result : Name := "");
function Found (Pattern : String := "";
File : Name := "<IMAGE>";
Wildcards : Boolean := False;
Ignore_Case : Boolean := True) return Natural;
-- find instances of Pattern in File, optionally using Wildcards
procedure Append (Source : Name := ""; Target : Name := "<SELECTION>");
-- append the contents of one file to another
procedure Dump (File : Name := "<SELECTION>";
Page_Number : Natural := 0;
Word_Number : Natural := 0;
Word_Count : Positive := 64);
-- display a hex dump of the file. A "word" is 16 bytes.
-- Defaults dump the first page of the file.
procedure Sort (File : Name := "<IMAGE>";
Result : Name := "";
Key_1 : String := "";
Key_2 : String := "";
Key_3 : String := "");
--
-- Sort File using Key_n as sort keys.
--
-- Key_1 is most signficant. Key_2 is ignored if Key_1 not specified, etc.
-- No keys cause ascending Ascii sort on full-line compare.
--
-- Key_n follow form parameter syntax, parameters are first-character
-- unique, so any prefix of the names is sufficient.
--
-- FIELD => number
--
-- Field is a field on the line. Fields are non-blank characters
-- separated by blanks. Field 1 is the first field. Field 1
-- always includes column 1, even if blank. If no field is given,
-- the entire line, blanks included is the field.
--
-- START_COLUMN => number (default is 1)
--
-- The starting column relative to the start of the field.
--
-- END_COLUMN => number (default is Integer'Last)
--
-- The ending column relative to the start of the field.
--
-- REVERSE => true | FALSE
--
-- True implies sort descending for this key.
--
-- NUMERIC => true | FALSE
--
-- Perform the sort on the numeric value of the field represented
-- as a Long_Integer.
--
-- Examples:
--
-- "F=2, S=5, E=7, R, N" will sort the field 2, columns 5 through 7,
-- descending (reversed) using a numeric comparison. Fully specified,
-- "Field => 2, Start_Column => 5, End_Column => 7, Reversed, Numeric"
--
-- "S=10, E=>15" will sort using Ascii ordering columns 10 through 15
-- of the entire line.
pragma Subsystem (Os_Commands);
pragma Module_Name (4, 3929);
end File_Utilities;with Profile;
with Ftp_Defs;
with Ftp_Profile;
with Ftp_Name_Map;
with File_Transfer;
package Ftp is
pragma Subsystem (Ftp_Interface, Private_Part => Closed);
pragma Module_Name (4, 3538);
function Profile_Get return Profile.Response_Profile renames Profile.Get;
-- This declaration is introduced to avoid a name collision.
----|| non-interactive transfers ||----
-- Move a file to some other machine:
procedure Put (From_Local_File : String := "<IMAGE>";
To_Remote_File : String := "";
Remote_Machine : String := Ftp_Profile.Remote_Machine;
Username : String := Ftp_Profile.Username;
Password : String := Ftp_Profile.Password;
Account : String := Ftp_Profile.Account;
Remote_Directory : String := Ftp_Profile.Remote_Directory;
Remote_Type : Ftp_Name_Map.Machine_Type :=
Ftp_Profile.Remote_Type;
Append_To_File : Boolean := False;
Transfer_Type : Ftp_Defs.Type_Code :=
Ftp_Profile.Transfer_Type;
Transfer_Mode : Ftp_Defs.Mode_Code :=
Ftp_Profile.Transfer_Mode;
Transfer_Structure : Ftp_Defs.Structure_Code :=
Ftp_Profile.Transfer_Structure;
Send_Port : Boolean := Ftp_Profile.Send_Port_Enabled;
Response : Profile.Response_Profile := Profile.Get);
-- Get a file from some other machine:
procedure Get (From_Remote_File : String := "";
To_Local_File : String := "";
Remote_Machine : String := Ftp_Profile.Remote_Machine;
Username : String := Ftp_Profile.Username;
Password : String := Ftp_Profile.Password;
Account : String := Ftp_Profile.Account;
Remote_Directory : String := Ftp_Profile.Remote_Directory;
Remote_Type : Ftp_Name_Map.Machine_Type :=
Ftp_Profile.Remote_Type;
Append_To_File : Boolean := False;
Transfer_Type : Ftp_Defs.Type_Code :=
Ftp_Profile.Transfer_Type;
Transfer_Mode : Ftp_Defs.Mode_Code :=
Ftp_Profile.Transfer_Mode;
Transfer_Structure : Ftp_Defs.Structure_Code :=
Ftp_Profile.Transfer_Structure;
Send_Port : Boolean := Ftp_Profile.Send_Port_Enabled;
Response : Profile.Response_Profile := Ftp.Profile_Get);
-- The following operations are more interactive, that is,
-- they require that you first establish a connection to
-- a remote machine, and then interact with it to transfer
-- files. Using FTP interactively allows you to do more
-- things than you can do non-interactively.
----|| login operations ||----
procedure Connect (To_Machine : String := Ftp_Profile.Remote_Machine;
Auto_Login : Boolean := Ftp_Profile.Auto_Login;
Username : String := Ftp_Profile.Username;
Password : String := Ftp_Profile.Password;
Account : String := Ftp_Profile.Account;
Remote_Directory : String :=
Ftp_Profile.Remote_Directory;
Remote_Roof : String := Ftp_Profile.Remote_Roof;
Remote_Type : Ftp_Name_Map.Machine_Type :=
Ftp_Profile.Remote_Type;
Transfer_Type : Ftp_Defs.Type_Code :=
Ftp_Profile.Transfer_Type;
Transfer_Mode : Ftp_Defs.Mode_Code :=
Ftp_Profile.Transfer_Mode;
Transfer_Structure : Ftp_Defs.Structure_Code :=
Ftp_Profile.Transfer_Structure;
Send_Port : Boolean := Ftp_Profile.Send_Port_Enabled;
Response : Profile.Response_Profile := Profile.Get);
procedure Login (Username : String := Ftp_Profile.Username;
Password : String := Ftp_Profile.Password;
Account : String := Ftp_Profile.Account;
Remote_Directory : String := Ftp_Profile.Remote_Directory;
Remote_Roof : String := Ftp_Profile.Remote_Roof;
Remote_Type : Ftp_Name_Map.Machine_Type :=
Ftp_Profile.Remote_Type;
Transfer_Type : Ftp_Defs.Type_Code :=
Ftp_Profile.Transfer_Type;
Transfer_Mode : Ftp_Defs.Mode_Code :=
Ftp_Profile.Transfer_Mode;
Transfer_Structure : Ftp_Defs.Structure_Code :=
Ftp_Profile.Transfer_Structure;
Send_Port : Boolean := Ftp_Profile.Send_Port_Enabled;
Response : Profile.Response_Profile := Profile.Get);
procedure Disconnect (Response : Profile.Response_Profile := Profile.Get);
procedure Abandon (Response : Profile.Response_Profile := Profile.Get);
-- Like Disconnect, but a bit stronger:
-- Guaranteed to terminate the connection,
-- even if the remote server is unresponsive.
----|| transfer parameter selection ||----
-- The following procedures override the FTP_Profile values,
-- but ONLY for the duration of the current connection.
-- To modify the FTP_Profile values, see FTP_Profile.Set.
procedure Use_Type (Value : Ftp_Defs.Type_Code := Ftp_Profile.Transfer_Type;
Response : Profile.Response_Profile := Profile.Get;
Account : String := Ftp_Profile.Account);
procedure Use_Mode (Value : Ftp_Defs.Mode_Code := Ftp_Profile.Transfer_Mode;
Response : Profile.Response_Profile := Profile.Get;
Account : String := Ftp_Profile.Account);
procedure Use_Structure (Value : Ftp_Defs.Structure_Code :=
Ftp_Profile.Transfer_Structure;
Response : Profile.Response_Profile := Profile.Get;
Account : String := Ftp_Profile.Account);
procedure Use_Account (Account : String := Ftp_Profile.Account;
Response : Profile.Response_Profile := Profile.Get);
procedure Send_Port (Enabled : Boolean := Ftp_Profile.Send_Port_Enabled;
Response : Profile.Response_Profile := Profile.Get);
procedure Use_Remote_Type
(Value : Ftp_Name_Map.Machine_Type := Ftp_Profile.Remote_Type;
Response : Profile.Response_Profile := Profile.Get);
procedure Use_Remote_Roof
(Value : String := Ftp_Profile.Remote_Roof;
Response : Profile.Response_Profile := Profile.Get);
function Current_Remote_Type return Ftp_Name_Map.Machine_Type
renames Ftp_Profile.Current_Remote_Type;
function Current_Remote_Roof return String
renames Ftp_Profile.Current_Remote_Roof;
function Current_Connection return File_Transfer.Connect_Id;
-- Returns the File_Transfer connection associated with the
-- caller's current session. File_Transfer operations, such
-- as querying the outcome of the last transaction, can be
-- performed on the resulting value.
----|| remote directory operations ||----
procedure Change_Working_Directory
(Remote_Directory : String := Ftp_Profile.Remote_Directory;
Response : Profile.Response_Profile := Profile.Get;
Account : String := Ftp_Profile.Account);
procedure Cwd (Remote_Directory : String := Ftp_Profile.Remote_Directory;
Response : Profile.Response_Profile := Profile.Get;
Account : String := Ftp_Profile.Account)
renames Change_Working_Directory;
procedure List (Remote_Pathname : String := "";
Verbose : Boolean := True;
To_Local_File : String :=
""; -- default is current output
Response : Profile.Response_Profile := Profile.Get;
Account : String := Ftp_Profile.Account);
procedure Delete (Remote_File : String;
Response : Profile.Response_Profile := Profile.Get;
Account : String := Ftp_Profile.Account);
----|| status operations ||----
procedure Status (Argument : String := "";
Response : Profile.Response_Profile := Profile.Get);
-- Display the status of the current connection.
procedure Status_All (Argument : String := "";
Response : Profile.Response_Profile := Profile.Get);
-- Display the status of all current connections.
procedure Remote_Status (Argument : String := "";
Response : Profile.Response_Profile := Profile.Get;
Account : String := Ftp_Profile.Account);
procedure Remote_Help (Argument : String := "";
Response : Profile.Response_Profile := Profile.Get;
Account : String := Ftp_Profile.Account);
procedure Show_Profile (Response : Profile.Response_Profile := Profile.Get)
renames Ftp_Profile.Show;
-- Display the settings in the current profile.
----|| file transfer operations ||----
procedure Store (From_Local_File : String := "<IMAGE>";
To_Remote_File : String := "";
Append_To_File : Boolean := False;
Response : Profile.Response_Profile := Profile.Get;
Remote_Type : Ftp_Name_Map.Machine_Type :=
Ftp.Current_Remote_Type;
Account : String := Ftp_Profile.Account);
procedure Retrieve (From_Remote_File : String := "";
To_Local_File : String := "";
Append_To_File : Boolean := False;
Response : Profile.Response_Profile := Profile.Get;
Remote_Type : Ftp_Name_Map.Machine_Type :=
Ftp.Current_Remote_Type;
Account : String := Ftp_Profile.Account);
----|| transferring file sets ||----
-- These operations are like their single-file cousins,
-- above, except that they take wildcards, and move a
-- bunch of files at a crack. They're designed to support
-- moving files between a subtree of the local directory
-- system (whose root is designated by "Local_Roof"), to
-- and from an isomorphic subtree of the remote directory
-- system (whose root is designated by "Remote_Roof".
-- File names are transformed between the naming conventions
-- of the R1000 and whatever remote operating system is
-- involved (designated by Remote_Type). The transformation
-- is complex: it is encapsulated in package FTP_Name_Map.
-- If you want to flatten a file_set, that is, move files from
-- many directories on one machine into a single directory on
-- another, specify "" as the source roof (local_roof for Put,
-- remote_roof for Get).
-- Get_List and Retrieve_List retrieve files using a list
-- stored in a file on your local machine. This file must
-- contain text, with one fully-qualified file name (in the
-- form used by the REMOTE machine) per line. No comments,
-- no extra white space.
-- Get_Set and Retrieve_Set depend on the remote machine to
-- produce a list of files from the File_Set you specify:
-- using the same primitive as List (Verbose => False).
-- Sometimes this doesn't work, either because the wild
-- card semantics on that machine won't stretch, or because
-- the remote FTP server doesn't support wild cards.
procedure Put_Set (From_Local_File_Set : String := "<IMAGE>";
Local_Roof : String := "$";
Remote_Roof : String := Ftp_Profile.Remote_Roof;
Remote_Machine : String := Ftp_Profile.Remote_Machine;
Username : String := Ftp_Profile.Username;
Password : String := Ftp_Profile.Password;
Account : String := Ftp_Profile.Account;
Remote_Directory : String :=
Ftp_Profile.Remote_Directory;
Remote_Type : Ftp_Name_Map.Machine_Type :=
Ftp_Profile.Remote_Type;
Append_To_File : Boolean := False;
Transfer_Type : Ftp_Defs.Type_Code :=
Ftp_Profile.Transfer_Type;
Transfer_Mode : Ftp_Defs.Mode_Code :=
Ftp_Profile.Transfer_Mode;
Transfer_Structure : Ftp_Defs.Structure_Code :=
Ftp_Profile.Transfer_Structure;
Send_Port : Boolean := Ftp_Profile.Send_Port_Enabled;
Response : Profile.Response_Profile := Profile.Get);
procedure Get_Set (From_Remote_File_Set : String := "";
Local_Roof : String := "$";
Remote_Roof : String := Ftp_Profile.Remote_Roof;
Remote_Machine : String := Ftp_Profile.Remote_Machine;
Username : String := Ftp_Profile.Username;
Password : String := Ftp_Profile.Password;
Account : String := Ftp_Profile.Account;
Remote_Directory : String :=
Ftp_Profile.Remote_Directory;
Remote_Type : Ftp_Name_Map.Machine_Type :=
Ftp_Profile.Remote_Type;
Append_To_File : Boolean := False;
Transfer_Type : Ftp_Defs.Type_Code :=
Ftp_Profile.Transfer_Type;
Transfer_Mode : Ftp_Defs.Mode_Code :=
Ftp_Profile.Transfer_Mode;
Transfer_Structure : Ftp_Defs.Structure_Code :=
Ftp_Profile.Transfer_Structure;
Send_Port : Boolean := Ftp_Profile.Send_Port_Enabled;
Response : Profile.Response_Profile := Profile.Get);
procedure Get_List (Remote_File_List : String := "";
Local_Roof : String := "$";
Remote_Roof : String := Ftp_Profile.Remote_Roof;
Remote_Machine : String := Ftp_Profile.Remote_Machine;
Username : String := Ftp_Profile.Username;
Password : String := Ftp_Profile.Password;
Account : String := Ftp_Profile.Account;
Remote_Directory : String :=
Ftp_Profile.Remote_Directory;
Remote_Type : Ftp_Name_Map.Machine_Type :=
Ftp_Profile.Remote_Type;
Append_To_File : Boolean := False;
Transfer_Type : Ftp_Defs.Type_Code :=
Ftp_Profile.Transfer_Type;
Transfer_Mode : Ftp_Defs.Mode_Code :=
Ftp_Profile.Transfer_Mode;
Transfer_Structure : Ftp_Defs.Structure_Code :=
Ftp_Profile.Transfer_Structure;
Send_Port : Boolean := Ftp_Profile.Send_Port_Enabled;
Response : Profile.Response_Profile := Profile.Get);
procedure Store_Set (From_Local_File_Set : String := "<IMAGE>";
Local_Roof : String := "$";
Remote_Roof : String := Ftp.Current_Remote_Roof;
Remote_Type : Ftp_Name_Map.Machine_Type :=
Ftp.Current_Remote_Type;
Append_To_File : Boolean := False;
Response : Profile.Response_Profile := Profile.Get;
Account : String := Ftp_Profile.Account);
procedure Retrieve_Set (From_Remote_File_Set : String := "";
Local_Roof : String := "$";
Remote_Roof : String := Ftp.Current_Remote_Roof;
Remote_Type : Ftp_Name_Map.Machine_Type :=
Ftp.Current_Remote_Type;
Append_To_File : Boolean := False;
Response : Profile.Response_Profile := Profile.Get;
Account : String := Ftp_Profile.Account);
procedure Retrieve_List (Remote_File_List : String := "";
Local_Roof : String := "$";
Remote_Roof : String := Ftp.Current_Remote_Roof;
Remote_Type : Ftp_Name_Map.Machine_Type :=
Ftp.Current_Remote_Type;
Append_To_File : Boolean := False;
Response : Profile.Response_Profile := Profile.Get;
Account : String := Ftp_Profile.Account);
----|| constants of imported types ||----
Ascii : constant Ftp_Defs.Type_Code := Ftp_Defs.Ascii;
Ebcdic : constant Ftp_Defs.Type_Code := Ftp_Defs.Ebcdic;
Image : constant Ftp_Defs.Type_Code := Ftp_Defs.Image;
Binary : constant Ftp_Defs.Type_Code := Ftp_Defs.Binary;
Local_Binary : constant Ftp_Defs.Type_Code := Ftp_Defs.Local_Binary;
Local_Byte : constant Ftp_Defs.Type_Code := Ftp_Defs.Local_Byte;
Ascii_Cc : constant Ftp_Defs.Type_Code := Ftp_Defs.Ascii_Cc;
Ebcdic_Cc : constant Ftp_Defs.Type_Code := Ftp_Defs.Ebcdic_Cc;
Ascii_Telnet : constant Ftp_Defs.Type_Code := Ftp_Defs.Ascii_Telnet;
Ebcdic_Telnet : constant Ftp_Defs.Type_Code := Ftp_Defs.Ebcdic_Telnet;
Stream : constant Ftp_Defs.Mode_Code := Ftp_Defs.Stream;
Block : constant Ftp_Defs.Mode_Code := Ftp_Defs.Block;
Compressed : constant Ftp_Defs.Mode_Code := Ftp_Defs.Compressed;
File : constant Ftp_Defs.Structure_Code := Ftp_Defs.File;
Recrd : constant Ftp_Defs.Structure_Code := Ftp_Defs.Recrd;
Page : constant Ftp_Defs.Structure_Code := Ftp_Defs.Page;
Rational : constant Ftp_Name_Map.Machine_Type := Ftp_Name_Map.Rational;
R1000 : constant Ftp_Name_Map.Machine_Type := Rational;
Unix : constant Ftp_Name_Map.Machine_Type := Ftp_Name_Map.Unix;
Aos : constant Ftp_Name_Map.Machine_Type := Ftp_Name_Map.Aos;
Mv : constant Ftp_Name_Map.Machine_Type := Aos;
Vms : constant Ftp_Name_Map.Machine_Type := Ftp_Name_Map.Vms;
Vax : constant Ftp_Name_Map.Machine_Type := Vms;
Mvs : constant Ftp_Name_Map.Machine_Type := Ftp_Name_Map.Mvs;
end Ftp;package Gateway is
procedure Create (Name : String := ">>OBJECT NAME<<";
Gateway_Class : String := ">>GATEWAY CLASS<<";
Value_Assignments : String := "";
Options : String := "";
Response : String := "<PROFILE>");
--
-- Create a Gateway object of the specified gateway class.
-- Value_Assignments provides a means of assigning properties
-- initial values. The string consists of zero or more property
-- specifications separated by commas or semicolons. Each property
-- specification is of the form:
--
-- Property_Name => Value
-- or
-- Property_Name(Subobject_Name) => Value
--
-- where Property_Name is the name of the gateway property to be assigned
-- a value (it may include embedded "." characters). The value is
-- a value acceptable to the Parameter_Parser which includes numeric
-- literals, identifiers, directory pathnames, and any sequence of
-- characters enclosed in balanced '(', ')' characters. The escape
-- character is '\' so that, for example, "\)" is an uninterpreted
-- right parenthesis.
--
-- Options specifies any additional parameters for this operation
-- (primarily for future additions).
--
procedure Set_Property (Gateway_Name : String := "<SELECTION>";
Property_Name : String := ">>PROPERTY NAME<<";
New_Property_Value : String := ">>PROPERTY VALUE<<";
Response : String := "<PROFILE>");
-- Set the named property in the named gateway object(s) to the named
-- value. Multiple objects may be specified via directory-name wildcards.
procedure Edit (Name : String := "<CURSOR>"; In_Place : Boolean := False);
-- Run editor on properties of a gateway object.
procedure Display (Name : String := "<CURSOR>"; Properties : String := "@");
-- Display the properties of the specified gateway object(s) whose name
-- matches Properties, as follows:
-- "@", "*", and "" specify all properties;
-- embedded '@'s and '*'s are treated as wildcards;
-- and matching is done on the property_name without the subobject name.
-- Multiple objects may be specified via directory-name wildcards
procedure Property_Edit (Name : String := "<CURSOR>";
In_Place : Boolean := False);
--
-- Run the editor on the properties of the specified gateway object.
-- The "data" image of the object, if any, is not generated or displayed
-- by this operation.
-------------------------
-- Editor operations:
-------------------------
procedure Insert (Spec : String := ">>Property_Name := Value<<";
Gateway_Object_Name : String := "");
-- The property values displayed in the specified or current DTIA property
-- Display Window are changed as indicated.
-- (Generated in response to Object."I" on a DTIA property Display Window)
-- The spec string specifies one or more properties to be set; the
-- syntax is identical that of Create's Value_Assigments parameter.
procedure Change (Image : String := ">>New Property Value<<";
Gateway_Object_Name : String := "");
-- The highlighted property in the current or specified DTIA property
-- display window is changed to the value of the given image.
-- (Generated in response to Edit on a DTIA property display window.)
procedure Write_Properties (Gateway_Object_Name : String := "");
-- The contents of the specified Gateway object's property display window
-- are stored in the object which is then committed.
-- A null name causes the current DTIA property display window's
-- properties are written to its Gateway object.
pragma Module_Name (4, 4125);
pragma Bias_Key (29);
pragma Subsystem (Tools_Integration);
end Gateway;package Gateway_Class is
procedure Build (Gateway_Class_Directory : String := "<IMAGE>";
Gateway_Text_Description : String := "Gateway_Definition";
Gateway_Binary_Description : String := "Gateway_Class";
Response : String := "<Profile>");
--
-- Compile the gateway class description from "Gateway_Definition"
-- producing the gateway class object "Gateway_Class".
-- Gateway_Class_Directory specifies the directory in
-- which the gateway class definitions exists.
-- Gateway_[Text,Binary]_Description are the source/destination of
-- the construction.
--
-- In general, only the directory name need be specified since the
-- filenames within !Machine.Gateway_Classes are standardized.
-- Gateway_Class_Directory is evaluated relative to the context
-- !Machine.Gateway_Classes so that a simple name can be used
-- for the gateway class name.
procedure Activate (Gateway_Class_Name : String :=
">>SIMPLE GATEWAY CLASS NAME<<";
Response : String := "<PROFILE>");
--
-- Activate the gateway class from !Machine.Gateway_Classes.<Class_Name>.
-- This makes the gateway class available for use on the system.
--
-- Open the gateway class definition file in !machine.<Class_Name>.Class.
-- Place the pointer to it in the in-memory cache and hold the
-- update lock on the gateway class file.
--
-- Start the global server for the gateway class, if there is one.
procedure Deactivate (Gateway_Class_Name : String :=
">>SIMPLE GATEWAY CLASS NAME<<";
Response : String := "<PROFILE>");
--
-- Remove the active class entry and release the lock on the file.
-- Operations on objects of inactive gateway classes are not
-- allowed. In addition, after the gateway class is deactivated, images
-- of objects of that gateway classe will be removed from screens,
-- servers for that gateway class will be terminated, and further
-- operations disallowed until the gateway class is reactivated.
procedure Display (Gateway_Class_Name : String := "@");
-- Display a formatted report of registered gateway
-- classes and information about them whose names match
-- the specified naming expression. The Gateway_Class_Name parameter
-- is resolved in the context !Machine.Gateway_Classes.
procedure Boot_Time_Initialization;
--
-- Call from !Machine.Initialize. Activates all gateway classes
-- for which the file Activate_On_Boot is present in the gateway
-- class directory.
pragma Module_Name (4, 3996);
pragma Bias_Key (29);
pragma Subsystem (Tools_Integration);
end Gateway_Class;with Machine;
package Job is
subtype Id is Machine.Job_Id;
-- start, stop and terminate a job
procedure Kill (The_Job : Id; The_Session : String := "");
procedure Disable (The_Job : Id; The_Session : String := "");
procedure Enable (The_Job : Id; The_Session : String := "");
procedure Interrupt;
procedure Connect (The_Job : Id := 0);
procedure Disconnect (The_Job : Id := 0);
procedure Set_Termination_Message (S : String := "");
pragma Subsystem (Command);
pragma Module_Name (4, 2206);
end Job;with Profile;
with Compilation;
package Library is
subtype Name is String;
-- Lexically and syntactically an Ada Name.
subtype Simple_Name is String;
-- A simple Ada name. Basically, an identifier or operator.
subtype Context_Name is Name;
-- Treatment of context. There is a current context that constitutes
-- the assumed naming context. Names are resolved in this context.
-- The following characters modify the context:
-- ! specifies the Universe context
-- $ specifies the enclosing library for the current context.
-- $$ specifies the enclosing world for the current context.
-- ^ specifies the parent of the current context.
-- @ matches any single name segment (or part thereof)
-- ? matches 0 or more name segments, only the last of which may be a
-- world.
-- ?? matches 0 or more name segments.
-- The special stings "<IMAGE>", etc., attempt to get the designated
-- object from the current selection/image.
-- Note that many commands are recursive by default (they are
-- recognizable as such by the presence of a Recursive parameter). When
-- the Recursive parameter is true, all descendents of the specified
-- objects partake in the operation. When Recursive is false, just the
-- specified objects partake.
-- The effects of the Recursive option can also be obtained using "?"
-- wildcards, but with more writing. In any case, an object is operated
-- on only once whether it is introduced by an input parameter or the
-- recursive option or both.
Error : exception renames Profile.Error;
-- Only the single exception Error is raised
procedure Resolve (Name_Of : Name := "<TEXT>";
Target_Name : Name := "";
Objects_Only : Boolean := True;
Response : String := "<PROFILE>");
-- Print the Full name for Name_Of. Defaults to the current selection's
-- text.
procedure Enclosing_World (Levels : Positive := 1;
Response : String := "<PROFILE>");
-- Enclosing_World is equivalent to Context ("^$$");
procedure Context (To_Be : Context_Name := "$";
Response : String := "<PROFILE>");
-- Set the job context to To_Be. When To_Be is already the job context,
-- only printing takes place.
procedure Copy (From : Name := "<REGION>";
To : Name := "<IMAGE>";
Recursive : Boolean := True;
Response : String := "<PROFILE>";
Copy_Links : Boolean := True;
Options : String := "");
-- Copy version From resulting in version To; see table below.
-- To designates an object that will exist after the copy has
-- completed. For Ada objects, changing the simple name may require
-- user intervention before installation.
-- To is interpreted in the current context or specified full
-- context and must be unique.
-- The object designated by To will be the same class as From.
-- Objects representing devices cannot be copied.
-- Any situation that would require demoting unrelated declarations
-- results in an error, suppressing the copy.
-- Recursive applies to objects that contain other objects and indicates
-- that these contained objects should be copied.
-- If Copy_Links is true, then link packs for any worlds copied are
-- duplicated, and any link which pointed to the source for a copy is
-- altered to point to the destination. If Copy_Links is false, any
-- copied worlds will have empty link packs.
-- If a world and its switch file are copied, then the copied unit will
-- point to the copy of the switch file. If the switch file is not
-- copied, then the unit and its original will reference the same switch
-- file.
-- Ada units are copied as source.
-- Copy and Move subsume the functionality of Copy_Into and Move_Into
-- from previous releases. Whether a Copy/Move is "to" or "into" is
-- determined by the type of object specified by the From and To
-- parameters. The chart below gives the details.
-- If wildcards/substitution characters are involved in the From and To
-- parameters, this matrix is applied AFTER these wildcards have been
-- expanded. If the source is over-specified (e.g., "?" is used with
-- the recursive switch) a source object is copied only once.
-- COPY/MOVE to/into matrix
--
-- \ TO
-- +---------+---------+---------+--------+--------+----------
-- FROM | Non-Ada | Library | Subunit | World | Drctry | No Object
-- | Object | Unit | | | |
-- --------+---------+---------+---------+--------+--------+----------
-- Non-Ada | | | | | |
-- Object | TO (1) | Error | Error | INTO | INTO | TO
-- | | | | | |
-- --------+---------+---------+---------+--------+--------+----------
-- Library | | | | | |
-- Unit | Error | TO | TO | INTO | INTO | TO
-- (2) | | | | | |
-- --------+---------+---------+---------+--------+--------+----------
-- Subunit | | | | | |
-- (2) | Error | INTO | TO | INTO | INTO | TO
-- | | | | | |
-- --------+---------+---------+---------+--------+--------+----------
-- World | | | | | |
-- (3) | Error | Error | Error | TO (4) | TO (4) | TO
-- | | | | | |
-- --------+---------+---------+---------+--------+--------+----------
-- Drctry | | | | | |
-- (3) | Error | Error | Error | TO (4) | TO (4) | TO
-- | | | | | |
-- --------+---------+---------+---------+--------+--------+----------
--
-- Notes:
--
-- 1. User can make any "TO" an "INTO" by appending ".name" to To;
-- Appending ".#" would yield target with same simple name as From.
--
-- 2. Any class mismatch is an error.
--
-- 3. Subunits of unit are involved if Recursive switch is set;
-- nesting of subunits is preserved.
--
-- 4. Subcomponents of library are involved if Recursive switch is set;
-- relative nesting of subcomponents is preserved.
--
-- 5. Contents of source library are merged with contents of
-- target library.
--
procedure Move (From : Name := "<REGION>";
To : Name := "<IMAGE>";
Recursive : Boolean := True;
Response : String := "<PROFILE>";
Copy_Links : Boolean := True;
Options : String := "");
-- Equivalent to Copy (Existing, ...); Delete (Existing);
subtype Volume is Natural range 0 .. 31;
Nil : constant Volume := Volume'First;
type Kind is (World, Directory, Subpackage);
procedure Create (Name : Library.Name := ">>LIBRARY NAME<<";
Kind : Library.Kind := Library.Directory;
Vol : Volume := Library.Nil;
Model : String := "!Model.R1000";
Response : String := "<PROFILE>");
--
-- Create a library of the specified type. The Nil volume represents
-- the 'best' volume (The 'best' volume does not necessarily mean the
-- volume with the most space. The 'best' volume calculation takes into
-- account the percentage of a volume that is available and an estimate
-- of the real consumption of previously allocated worlds). Vol is
-- ignored for Subpackages, which are not control points, and must be on
-- the same volume as their parent. When creating a World, links are
-- copied from Model (unless it is "").
procedure Rename (From : Name := "<SELECTION>";
To : Simple_Name := ">>NEW SIMPLE NAME<<";
Response : String := "<PROFILE>");
-- Change the name of an existing library unit or managed object.
-- References to library units are not changed -- only the actual
-- name of the unit. Various other restrictions apply.
procedure Delete (Existing : Name := "<SELECTION>";
Limit : Compilation.Change_Limit := "<DIRECTORIES>";
Response : String := "<PROFILE>")
renames Compilation.Delete;
-- Delete versions of objects designated by Existing. Either an object
-- must be selected, or the name of an object supplied.
-- Results will be reversible with Undelete, unless retention count = 0.
procedure Destroy (Existing : Name := "<SELECTION>";
Threshold : Natural := 1;
Limit : Compilation.Change_Limit := "<DIRECTORIES>";
Response : String := "<PROFILE>")
renames Compilation.Destroy;
-- Destroy versions and associated declarations designated by Existing.
-- Destroyed versions are expunged and cannot be undeleted.
procedure Undelete (Existing : Name := "<CURSOR>";
Response : String := "<PROFILE>");
-- Undelete an Existing version.
-- Only a fixed number of deleted versions will be retained. Excess
-- versions will be automatically expunged, at which time they can no
-- longer be undeleted.
Default_Keep_Versions : constant := -1;
-- Keep the default number of deleted versions.
procedure Expunge (Existing : Name := "<IMAGE>";
Keep_Versions : Integer := 0;
Recursive : Boolean := True;
Response : String := "<PROFILE>");
-- Make deletions permanent. Recursive causes subobjects to be
-- expunged. Keep_Versions deleted versions will be retained.
-- Recursive causes subobjects to be touched. Use Recursive => false
-- and "?" wildcard to avoid expunging nested worlds.
procedure Set_Retention_Count
(Existing : Name := "<IMAGE>";
Keep_Versions : Integer := Library.Default_Keep_Versions;
Recursive : Boolean := True;
Response : String := "<PROFILE>");
-- Set the default number of deleted versions of an object which are
-- retained. Default is the same as the object's parent. Recursive
-- causes subobjects to be touched. Use Recursive => false and "?"
-- wildcard to avoid setting retention count for nested worlds.
procedure Freeze (Existing : Name := "<IMAGE>";
Recursive : Boolean := True;
Response : String := "<PROFILE>");
-- Prevent further changes to an object. Recursive causes subobjects to
-- be frozen. Use Recursive => false and "?" wildcard to avoid freezing
-- nested worlds.
procedure Unfreeze (Existing : Name := "<IMAGE>";
Recursive : Boolean := True;
Response : String := "<PROFILE>");
-- Permit changes to an object. Recursive causes subobjects to be
-- unfrozen. Use Recursive => false and "?" wildcard to avoid
-- unfreezing nested worlds.
procedure Default (Existing : Name := "<SELECTION>";
Response : String := "<PROFILE>");
-- Set the default Version for the existing object and print the result
-- as a message.
procedure Set_Subclass (Existing : Name := "<SELECTION>";
To_Subclass : String := "";
Response : String := "<PROFILE>");
-- Set the subclass of an object. A null string for To_Subclass
-- requests the system to set the subclass to its 'best guess'.
type Field is (Object, -- Ada name.
Version, -- Version name.
Class, -- Directory class name.
Subclass, -- Subclass of the object.
Updater, -- User to last update object.
Update_Time, -- Time of last update.
Creator, -- User who created object.
Create_Time, -- Time of creation.
Reader, -- User to last read object.
Read_Time, -- Time of last read.
Size, -- Current size of object.
Status, -- Source, Installed, Coded, Elaborated, etc.
Frozen, -- Is this object frozen.
Retain, -- Max. number of deleted versions retained.
Declaration -- Ada declaration of object.
);
type Fields is array (Field) of Boolean;
Verbose_Format : constant Fields := Fields'(Object .. Update_Time => True,
Size .. Retain => True,
others => False);
Ada_Format : constant Fields :=
Fields'(Status => True, Declaration => True, others => False);
All_Fields : constant Fields := Fields'(others => True);
Terse_Format : constant Fields := Fields'(Object => True, others => False);
procedure List (Pattern : Name := "<IMAGE>@";
Displaying : Fields := Library.Terse_Format;
Sorted_By : Field := Library.Object;
Descending : Boolean := False;
Response : String := "<PROFILE>";
Options : String := "");
procedure Verbose_List (Pattern : Name := "<IMAGE>{@'V(ALL)}";
Displaying : Fields := Library.Verbose_Format;
Sorted_By : Field := Library.Object;
Descending : Boolean := False;
Response : String := "<PROFILE>";
Options : String := "") renames List;
procedure File_List (Pattern : Name := "<IMAGE>@'C(FILE)";
Displaying : Fields := Library.Verbose_Format;
Sorted_By : Field := Library.Object;
Descending : Boolean := False;
Response : String := "<PROFILE>";
Options : String := "") renames List;
procedure Ada_List (Pattern : Name := "<IMAGE>@'C(ADA)";
Displaying : Fields := Library.Ada_Format;
Sorted_By : Field := Library.Declaration;
Descending : Boolean := False;
Response : String := "<PROFILE>";
Options : String := "") renames List;
procedure Space (For_Object : Name := "<IMAGE>";
Levels : Positive := 2;
Recursive : Boolean := True;
Each_Object : Boolean := False;
Each_Version : Boolean := False;
Space_Types : Boolean := False;
Response : String := "<PROFILE>";
Options : String := "");
-- Show the space utilization (in pages) for For_Object. Also
-- display space usage for contained libraries to depth specified
-- by Levels. The space includes subobjects and contained libraries,
-- unless Recursive is false, in which case only the space for the
-- specified object is displayed. Thus, if Recursive is true, the
-- space is cumulatively totalled.
--
-- Each_Object causes the individual space the each object to be included
-- in the display in addition to libraries.
--
-- If Space_Types is true, a different display showing space broken down
-- by category (including the object itself, code segment, attribute
-- spaces, and list files) is displayed. In this case, the Each_Version
-- parameter will show information for each version of each object.
-- Each_Version is used only if Space_Types true. Levels is used only
-- if Space_Types is false.
procedure Compact_Library (Existing : Name := "<SELECTION>";
Response : String := "<PROFILE>");
-- This procedure may be used to reduce the amount of storage consumed
-- by frequently modified directories which are used to store files.
-- Quiet forms similar to those in Library_Object_Editor, but
-- these commands work based on the current context rather than
-- the current image.
procedure Create_World (Name : Library.Name := ">>WORLD NAME<<";
Kind : Library.Kind := Library.World;
Vol : Volume := Library.Nil;
Model : String := "!Model.R1000";
Response : String := "<PROFILE>") renames Create;
procedure Create_Directory (Name : Library.Name := ">>DIRECTORY NAME<<";
Kind : Library.Kind := Library.Directory;
Vol : Volume := Library.Nil;
Model : String := "";
Response : String := "<PROFILE>")
renames Create;
procedure Create_Unit (Name : Library.Name := ">>ADA NAME<<";
Kind : Library.Kind := Library.Subpackage;
Vol : Volume := Library.Nil;
Model : String := "";
Response : String := "<PROFILE>") renames Create;
procedure Display (Name : Library.Name := "[]");
-- Display the named object in a library window.
procedure Reformat_Image (Existing : Name := "<SELECTION>";
Response : String := "<PROFILE>");
-- Cause the image for a unit to be reconstructed.
pragma Subsystem (Commands);
pragma Module_Name (4, 3921);
end Library;with Links_Implementation;
package Links is
subtype World_Name is String;
-- The string name for any directory object may be given for a world
-- parameter, to indicate the world that contains the object.
subtype Link_Name is String;
-- An Ada simple name. When used as an in-parameter, except in Add and
-- Replace, it may contain wildcard characters. In Add and Replace it
-- may contain substitution characters.
subtype Source_Name is String;
-- A directory string name that specifies an existing Ada Library Unit.
-- (The unit does not have to be installed, but its declaration must be
-- in a library.) May contain wildcard characters when used as an
-- in-parameter.
subtype Source_Pattern is String;
-- A string (containing wildcards) which will be matched against the
-- full names of the objects denoted by links.
subtype Link_Kind is Links_Implementation.Link_Kind;
Internal : constant Link_Kind := Links_Implementation.Internal;
External : constant Link_Kind := Links_Implementation.External;
Any : constant Link_Kind := Links_Implementation.Any;
-- A link is Internal if its source object is in the world of the link
-- pack; otherwise it is External.
procedure Add (Source : Source_Name := ">>SOURCE NAMES<<";
Link : Link_Name := "#";
World : World_Name := "<IMAGE>";
Response : String := "<PROFILE>");
-- For each Ada library unit defined by Source, a link is created in the
-- link pack for World. The Source object is associated with the simple
-- Ada name given by Link. The operation fails if the specified Link name
-- already exists in the pack, unless the new link is compatible with the
-- old link. The new link is defined to be compatible with the old link
-- iff both links refer to the same object or the object referred to be the
-- old link has been deleted.
procedure Replace (Source : Source_Name := ">>SOURCE NAMES<<";
Link : Link_Name := "#";
World : World_Name := "<IMAGE>";
Response : String := "<PROFILE>");
-- For each Ada Library unit defined by Source, a link is created in
-- the link pack for World. The Source object is associated with the
-- simple Ada name given by Link. If a link of the same name
-- already exists, it is replaced by the new definition.
procedure Delete (Link : Link_Name := ">>LINK NAMES<<";
Source : Source_Pattern := "?";
Kind : Link_Kind := Links.Any;
World : World_Name := "<IMAGE>";
Response : String := "<PROFILE>");
-- The Links that match both the Source and Link wildcards and the
-- specified kind are deleted from the link pack of the given World.
procedure Copy (Source_World : World_Name := ">>WORLD NAME<<";
Target_World : World_Name := "<IMAGE>";
Link : Link_Name := "@";
Source : Source_Pattern := "?";
Kind : Link_Kind := Links.Any;
Response : String := "<PROFILE>");
-- The Links of Source_World that match the specified Source and Link
-- names and the given Link_Kind are copied to Target_World.
procedure Display (World : World_Name := "<IMAGE>";
Link : Link_Name := "@";
Source : Source_Pattern := "?";
Kind : Link_Kind := Links.Any;
Response : String := "<PROFILE>");
-- Lists the links that match the given wild cards in the given world
procedure Dependents (Link : Link_Name := "@";
Source : Source_Pattern := "?";
Kind : Link_Kind := Links.Any;
World : World_Name := "$$";
Response : String := "<PROFILE>");
-- Computes the Library Units of the world that are installed or coded
-- and reference any of the Link commands specified by the Source and
-- Link parameters.
procedure Edit (World : World_Name := "<IMAGE>");
procedure Visit (World : World_Name := "<IMAGE>");
-- Enters the links object editor. If there is no links window for the
-- world to be edited, edit will create a new window, and visit will
-- reuse an existing window of there is one.
procedure Insert (Source : Source_Name := ">>SOURCE NAME<<");
procedure Update (Source : Source_Name := ">>SOURCE NAME<<");
-- Insert and Update peform the same function as Add and Replace, but
-- they must be run in a command window off a links image.
procedure Expunge (World : World_Name := "<IMAGE>";
Response : String := "<PROFILE>");
pragma Subsystem (Commands);
pragma Module_Name (4, 3938);
end Links;with Io;
with Diana;
with Directory;
with Error_Messages;
with Machine;
with Profile;
with Simple_Status;
package Log is
subtype Name is String; -- an unambiguous string name
procedure Set_Log (To_Be : Name := ">>FILE NAME<<";
Filter : Profile.Log_Filter := Profile.Filter);
-- Set Current_Output to To_Be, changing the profile to direct log
-- output to Use_Current_Output. Change the Log_Filter to Filter.
-- If To_Be cannot be created, Current_Output is not redirected, but
-- no exception is raised.
procedure Reset_Log (Filter : Profile.Log_Filter := Profile.Filter);
-- Equivalent to IO.Reset_..., but changes Log_Filter
procedure Put_System_Messages
(Response : Profile.Response_Profile := Profile.Get);
-- Copy contents of the message log for the current job into Current_Output
procedure Put_Job_Messages
(For_Job : Machine.Job_Id;
Response : Profile.Response_Profile := Profile.Get);
-- Copy contents of the message log for specified job into Current_Output
procedure Put_Condition
(Status : Simple_Status.Condition;
Response : Profile.Response_Profile := Profile.Get);
-- Display contents of Status in Current_Output.
procedure Put_Line (Message : String;
Kind : Profile.Msg_Kind := Profile.Note_Msg;
Response : Profile.Response_Profile := Profile.Get);
-- Appends the Message to the end of the Current_Output as described by
-- the given response profile. If Profile.Includes (Kind, Response) is
-- true, then the messages is generated as described below; otherwise
-- the Put_line call returns immediately.
-- The Time, Date and Symbol prefixes are printed first, in the order
-- and format specified by the Profile.Prefixes (Response) array.
-- If the Profile.Symbols prefix is requested, a unique three-character
-- string is generated for each possible vale of Kind:
-- -- KIND -- Symbol Excplanation
-- Position_Msg >>>
-- Identifies the location in a file or program
-- to which subsequent messages refer.
-- Sharp_Msg ### \
-- Dollar_Msg $$$ + Available for user-defined purposes
-- At_Msg @@@ /
-- Debug_Msg ???
-- Auxiliary_Msg :::
-- Note_Msg ---
-- Supplemental information.
-- Positive_Msg +++
-- Indicates that a major step in the process has
-- completed successfully. e.g. a unit has been
-- compiled, or generation of an output file is
-- complete.
-- Warning_Msg !!!
-- Indicates a minor problem in processing a major
-- step of the process. Warnings generally do not
-- lead to negative messages (see below).
-- Negative_Msg ++*
-- Indicates that a major step in the process has
-- completed unsuccessfully. e.g. a unit has failed
-- to compile, or generation of an output file is
-- could not be accomplished.
-- Error_Msg ***
-- Indicates a significant problem within a major
-- step of the process that has been detected by
-- the command. Error messages will
-- frequently be followed by negative messges
-- Exception_Msg %%%
-- Indicates that a command caught an unexpected
-- exception.
-- The text of the message follows the prefixes. If the message line
-- exceeds Profile.Width (Response), it is continued on the next line.
-- Each continuation line starts with the same prefixes as the first
-- line, except that the three-character string "..." is used instead
-- of the symbols in the table above. (If no Symbols prefix is
-- requested by the Profile.Prefixes (Response), the symbol string
-- "... " is inserted between the rightmost prefix and the message text.)
procedure Copy (Log_File : Name := "<IMAGE>";
Destination : Name := "";
Filter : Profile.Log_Filter := Profile.Filter);
-- Once a log file has been generated with symbol prefixes, the
-- following procedures may be used to copy the file while filtering
-- out unwanted messages. The default destination is Current_Output
procedure Filter (Log_File : Name := "<IMAGE>";
Destination : Name := "";
Auxiliaries : Boolean := True;
Diagnostics : Boolean := True;
Notes : Boolean := True;
Positives : Boolean := True;
Negatives : Boolean := True;
Positions : Boolean := True;
Warnings : Boolean := True;
Errors : Boolean := True;
Exceptions : Boolean := True;
Sharps : Boolean := True;
Dollars : Boolean := True;
Ats : Boolean := True);
procedure Summarize (Log_File : Name := "<IMAGE>";
Destination : Name := "";
Auxiliaries : Boolean := True;
Diagnostics : Boolean := True;
Notes : Boolean := False;
Positives : Boolean := True;
Negatives : Boolean := True;
Positions : Boolean := False;
Warnings : Boolean := False;
Errors : Boolean := False;
Exceptions : Boolean := False;
Sharps : Boolean := False;
Dollars : Boolean := False;
Ats : Boolean := False) renames Filter;
procedure Filter_Errors (Log_File : Name := "<IMAGE>";
Destination : Name := "";
Auxiliaries : Boolean := True;
Diagnostics : Boolean := True;
Notes : Boolean := False;
Positives : Boolean := False;
Negatives : Boolean := True;
Positions : Boolean := False;
Warnings : Boolean := True;
Errors : Boolean := True;
Exceptions : Boolean := False;
Sharps : Boolean := False;
Dollars : Boolean := False;
Ats : Boolean := False) renames Filter;
procedure Set_Error (To_Be : Name := ">>FILE NAME<<");
procedure Set_Input (To_Be : Name := "<REGION>") renames Io.Set_Input;
procedure Set_Output (To_Be : Name := ">>FILE NAME<<");
-- Set_Output and Set_Error deal with interaction with profiles that
-- direct Log output to streams other than Current_Output.
procedure Pop_Error renames Io.Pop_Error;
procedure Pop_Input renames Io.Pop_Input;
procedure Pop_Output renames Io.Pop_Output;
procedure Reset_Error renames Io.Reset_Error;
procedure Reset_Input renames Io.Reset_Input;
procedure Reset_Output renames Io.Reset_Output;
procedure Flush (Response : Profile.Response_Profile := Profile.Get);
-- force any log output into the log file
procedure Save (Response : Profile.Response_Profile := Profile.Get);
-- make the current contents of the log file permanent; calls flush
generic
type Object_Type is private;
with function Full (Object : Object_Type) return String;
with function Simple (Object : Object_Type) return String;
with function Is_Nil (Object : Object_Type) return Boolean;
with function Nil return Object_Type;
procedure Put_Line_Generic
(Object1 : Object_Type;
Message : String := "";
Object2 : Object_Type := Nil;
Kind : Profile.Msg_Kind := Profile.Note_Msg;
Response : Profile.Response_Profile := Profile.Get);
procedure Put_Line (Object1 : Directory.Object;
Message : String := "";
Object2 : Directory.Object := Directory.Nil;
Kind : Profile.Msg_Kind := Profile.Note_Msg;
Response : Profile.Response_Profile := Profile.Get);
procedure Put_Line (Object1 : Directory.Version;
Message : String := "";
Object2 : Directory.Version := Directory.Nil;
Kind : Profile.Msg_Kind := Profile.Note_Msg;
Response : Profile.Response_Profile := Profile.Get);
procedure Put_Line (Object1 : Diana.Tree;
Message : String := "";
Object2 : Diana.Tree := Diana.Empty;
Kind : Profile.Msg_Kind := Profile.Note_Msg;
Response : Profile.Response_Profile := Profile.Get);
-- Enters a message into the log, if messages of the Kind specified
-- are to be included.
-- If the message does go into the log, the name of the specified
-- object(s) is computed and inserted into the text of the message.
-- The location for the name of the first object is indicated by the
-- symbol "<1>"; if this string is not found in the message, the
-- name of the object is placed at the beginning of the message.
-- The location for the name of the object object is indicated by the
-- symbol "<2>"; if this string is not found in the message, the
-- name of the object, if not nil, is placed at the end of the message.
-- Directory.Naming.Unique_Full_Name is used to generate the name of
-- the object when the symbols given above are used or if no symbols
-- are found. The symbols "<<1>>" and "<<2>>" cause the value of
-- Directory.Naming.Get_Simple_Name to be used instead.
procedure Put_Errors (Errors : Error_Messages.Errors;
Response : Profile.Response_Profile := Profile.Get);
-- Enter the Error messages into the log.
function Image (Kind : Profile.Msg_Kind) return String;
-- Returns the three-letter prefix used for the indicated Msg_Kind.
pragma Subsystem (Input_Output);
pragma Module_Name (4, 3218);
end Log;with System_Utilities;
package Mail is
procedure Create (Mailbox : String := ">>SIMPLE NAME<<";
For_User : String := "");
-- Create a mailbox. For_User defaults to current user.
-- The user is added to the local machine name map.
--
procedure Edit (Mailbox : String := "MAIN"; For_User : String := "");
-- Enters the mail object editor. If no window exists for the given
-- mailbox, a new window will be created.
-- For_User defaults to current user.
procedure Expunge;
-- This command is only valid in a command window off of a mailbox
-- window. The given mailbox is expunged.
procedure Answer (To_All : Boolean := False);
-- This command may be used in a mailbox window or a read mail window.
-- It causes an answer window to be created with certain fields
-- initialized with appropriate default values.
-- In a mailbox window, the selected message is answered. In a read
-- mail window, the current message is answered.
procedure Reply (To_All : Boolean := False) renames Answer;
procedure Forward;
-- Same as answer, except a forward window is created.
procedure Remail;
-- Same as answer, except a remail window is created.
procedure Send;
-- Brings up a send window.
procedure Reload_Name_Map;
-- Causes the mail object editor to read in the name map.
function New_Messages return Natural;
-- returns number of unread messages in the mailbox; if the mailbox is
-- locked by another session or user the function returns 99999999.
procedure Send_Message (To : String := ">>USER_NAMES<<";
Subject : String := "";
Text : String := "";
Cc : String := "";
From : String := System_Utilities.User_Name;
Response : String := "<PROFILE>");
-- Composes and sends a message with content as specified by the parameters
procedure Notify;
-- Display the number of unread messages in the message window banner.
---------------------------------------------------------------------
-- The mail object editor manages three types of windows:
-- 1) Mailbox windows
-- 2) Read message windows and
-- 3) Transmit windows (answer, forward, remail, and send).
-- The following is a list of supported common commands per window type.
-- Mailbox window common commands:
--
-- Release (obj-x and obj-g). Deletes the window and closes the mailbox.
-- Any windows on objects within this mailbox will also be deleted.
-- Copy. Copy the selected message(s) from one mailbox to another.
-- Delete. Delete the selected message(s). If the selected message(s)
-- is already flagged for deletion, the message(s) are expunged.
-- Definition. If the cursor is on a message header, brings up a window
-- on the underlying message. If the cursor is on a mailbox name, brings
-- up a window on the underlying mailbox.
-- Format. Reads in new messages, and positions the cursor on the first
-- new message.
--
-- Insert. Bring up a send window.
--
-- Move. Move selected message from one mailbox to another.
-- Redo. If the selected message is an undeliverable notification a
-- send window is brought up with the original message ready to be
-- resent. Otherwise a reply window is brought up.
-- Revert. Same as format.
-- Sort_Image. Change the sort order in which the messages are displayed.
-- Undo. Undeleted selected message(s).
-- Read message window common commands:
-- Release. Delete the window, and position the cursor on the next
-- undeleted message in the mailbox window.
-- Delete. Same as Release, but underlying message is deleted.
-- Enclosing. Go to enclosing mailbox window.
-- Redo. Same as redo in a mailbox window.
-- Transmit window common commands:
-- Release. Obj-G deletes the window. Obj-X send the message, then
-- deletes the window.
-- Edit. Make the window editable.
-- Enclosing. If in a send window, goes to the users main mailbox.
-- Otherwise goes to the message being answered, forwarded or remailed.
-- Promote. Sends the message, and makes the window read only.
-- Semanticize. Check names in the to and cc lists, and underlines
-- names which can't be found.
-- The sort fields specified by the format parameter are as follows:
-- 1 From
-- 2 Date Received
-- 3 Date Sent
-- 4 Read/Unread
-- 5 Deleted/Non-deleted
-- Use the negatives of these numbers for reverse sorting.
-- Mail Switches:
-- Mail_Multiple_Message_Windows
-- Boolean indicating whether read window should be reused
--
-- Mail_Default_Sort_Order
-- Integer (see comment on sort orders)
pragma Subsystem (Mail);
pragma Module_Name (4, 3604);
pragma Bias_Key (15);
end Mail;package Menu_Operations is
-----------------------------------------------------------------------
-- This package is not yet fully implemented. Most routines will --
-- cause the exception Nonexistent_Page_Error to be raised. It is --
-- included as part of the environment in anticipation of the --
-- requirements of future Rational products. --
-----------------------------------------------------------------------
subtype Menu_Item is Integer;
procedure Dispatch (Item : Menu_Item; Parameter : String := "");
procedure Fastpatch (Item : Menu_Item; Parameter : String := "");
-- Dialog box completion operations. Do not call directly!
subtype Box_Id is Natural;
procedure Click_Ok (Id : Box_Id := 0; Parms : String := "");
--
-- unless id /= 0 and parms non null, read the input from the
-- keyboard in raw mode.
type Subsystem_Kind is (Spec_Load, Combined);
type View_Kind is (Spec_Load, Combined);
type Switch_Kind is (Library_Switches, Session_Switches);
type Activity_Copy_Kind is (Exact_Copy, Value_Copy, Differential);
type Goal_State is (Archived, Source, Installed, Coded);
type Compilation_Limit is (This_View_Or_World, All_Views_Or_Worlds);
type Backup_Kind is (Full, Incremental);
---------------
-- File Menu --
---------------
package File is
procedure New_File; -- Create a new file
procedure New_File (Name : String);
procedure New_Ada;
procedure New_World;
procedure New_World (Name : String;
Acl : String;
Default_Acl : String;
Retention_Count : Natural;
Model : String);
procedure New_Directory;
procedure New_Directory (Name : String);
procedure New_Subsystem;
procedure New_Subsystem (Name : String;
Kind : Subsystem_Kind;
Initial_View_Kind : View_Kind;
Initial_View_Name : String;
Model : String;
Comments_For_History : String);
procedure New_Working_View;
procedure New_Working_View (Name : String;
Copy_Of_View : String;
Kind : View_Kind;
Join : Boolean;
Imports : String;
Model : String;
Comments_For_History : String);
procedure New_Spec_View;
procedure New_Spec_View (Name : String;
Copy_Of_View : String;
Join : Boolean;
Imports : String;
Model : String;
Comments_For_History : String);
procedure New_Release_View;
procedure New_Release_View (Name : String;
Copy_Of_View : String;
Join : Boolean;
Imports : String;
Kind_Of_View : View_Kind;
Model : String;
Comments_For_History : String;
Configuration_Only : Boolean);
procedure New_Code_View;
procedure New_Code_View (Name : String;
Copy_Of_View : String;
Comments_For_History : String);
procedure New_Switch_File;
procedure New_Switch_File (Name : String; Kind : Switch_Kind);
procedure New_Activity;
procedure New_Activity (Name : String;
Copy_Of : String;
Copy_Mode : Activity_Copy_Kind);
procedure New_Mailbox;
procedure New_Mailbox (Name : String);
procedure New_Venture;
procedure New_Venture
(Name : String; Notes : String; Make_Default : Boolean);
procedure New_Work_Order;
procedure New_Work_Order (Name : String;
Notes : String;
Venture : String;
Work_Order_List : String);
procedure New_Work_Order_List;
procedure New_Work_Order_List
(Name : String; Venture : String; Make_Default : Boolean);
procedure New_System;
procedure New_System (Name : String; Initial_View_Name : String);
procedure New_Gateway;
procedure New_Gateway (Name : String; Gateway_Class : String);
procedure Open; -- Open a window on an object
procedure Open (Name : String; For_Edit : Boolean);
procedure Open_With_Demote (Name : String);
procedure Open_With_Check_Out (Name : String;
Comments_For_History : String);
-- should include comment about implicit accept changes
procedure Close; -- Close a window.
procedure Close_Commit (Do_Commit : Boolean);
procedure Save; -- Commit changes
procedure Revert; -- Revert to previous value. Ask about
-- losing changes if necessary.
procedure Revert_Lose_Changes;
procedure Print; -- Print an object or set of objects
procedure Print (Object_Or_Image : String;
From_First_Page : Natural;
To_Last_Page : Natural;
Display_As_Twoup : Boolean;
Display_Border : Boolean;
Display_Filename : Boolean;
Display_Date : Boolean;
Ignore_Display_Parameters_For_Postscript : Boolean;
Highlight_Reserved_Words_For_Ada : Boolean;
Other_Options : String;
Number_Of_Copies : Natural;
Printer : String;
Effort_Only : Boolean);
procedure Properties; -- View and edit properties of an object.
procedure File_Properties (Name : String;
Acl : String;
Frozen : Boolean;
Controlled : Boolean;
Checked_Out : Boolean); -- ***
procedure World_Properties (Name : String;
Acl : String;
Default_Acl : String;
Switch_File : String;
Retention_Count : Natural); -- ***
procedure Subsystem_Properties (Name : String); -- ***
procedure View_Properties (Name : String); -- ***
procedure Copy; -- Copy an object or objects
procedure Copy (Source : String; Destination : String);
procedure Move; -- Move an object or objects
procedure Move (Source : String; Destination : String);
procedure Delete; -- Delete an object or objects
procedure Delete (Name : String);
procedure Delete_Confirm (Name : String);
procedure Run; -- Run a command
procedure Run (Command_Name : String;
Parameters : String;
On_Machine : String);
procedure Quit; -- Logoff
procedure Quit_Confirm;
end File;
---------------
-- Edit menu --
---------------
package Edit is
procedure Format; -- Reformat object as appropriate
procedure Cut; -- delete selected text
procedure Copy; -- Copy selected text to buffer
procedure Paste; -- Paste in text from cut buffer
procedure Copy_To_Clipboard; -- Copy selected text to Motif clipboard
procedure Search_Forward; -- search text
procedure Search_Backward; -- search text toward beginning
procedure Replace; -- search and replace
procedure Check_Spelling_Word;
procedure Check_Spelling_Document; -- Spelling checker
procedure Insert_File; -- Insert contents of file
procedure Overwrite_Mode; -- enter overwrite mode
procedure Insert_Mode; -- enter insert mode
procedure Fill_Mode; -- enter fill mode
procedure No_Fill_Mode; -- exit fill mode
procedure Rename_Ada; -- withdraw Ada unit to rename.
procedure Underlines_Off;
end Edit;
-----------------
-- Region menu --
-----------------
package Region is
procedure Unselect;
procedure Beginning_Of;
procedure End_Of;
procedure Capitalize;
procedure Uppercase;
procedure Lowercase;
procedure Make_Comment;
procedure Uncomment;
procedure Fill;
procedure Justify;
end Region;
-------------------
-- Traverse Menu --
-------------------
package Traverse is
procedure Next_Item;
procedure Previous_Item;
procedure Definition;
procedure Enclosing;
procedure Other_Part;
procedure Home_Library;
procedure Resolve_Name;
procedure Resolve_Name (Name : String);
end Traverse;
------------------
-- Compile Menu --
------------------
package Compile is
procedure Semanticize;
procedure Code;
procedure Install;
procedure Install_Confirm;
procedure Source;
procedure Source_Confirm;
procedure Archive;
procedure Archive_Confirm;
procedure Options;
procedure Promote;
procedure Promote (Name : String;
Goal : Goal_State;
Limit : Compilation_Limit);
procedure Demote;
procedure Demote (Name : String;
Goal : Goal_State;
Limit : Compilation_Limit);
procedure Show_Usage;
procedure Show_Unused; -- not used anywhere
procedure Show_Unused_Local; -- unused in this unit
procedure Load;
procedure Load (Name : String; Result : String);
procedure Parse;
procedure Parse (Name : String; Destination_Directory : String);
procedure Build_Private_Part;
procedure Build_Body;
procedure Make_Separate;
procedure Make_Inline;
end Compile;
-------------
-- CM menu --
-------------
package Cm is
procedure Check_Out;
procedure Check_Out (Name : String; Comments : String);
procedure Check_Out_Confirm (Name : String; Comments : String);
procedure Check_In;
procedure Check_In (Name : String; Comments : String);
procedure Abandon;
procedure Abandon (Name : String);
procedure Abandon_Confirm (Name : String);
procedure Accept_Changes;
procedure Accept_Changes
(Name : String; Entire_View : Boolean; Source : String);
procedure Accept_Changes_Confirm
(Name : String; Entire_View : Boolean; Source : String);
procedure Join;
procedure Join (Name : String;
To_View : String;
Comments_For_History : String);
procedure Sever;
procedure Sever (Name : String; Comments_For_History : String);
procedure Imports;
procedure Imports (Views_To_Import : String;
Into_View : String;
Only_Change_Existing : Boolean);
procedure Properties;
end Cm;
----------------
-- Debug Menu --
----------------
package Debug is
procedure Go;
procedure Stop;
procedure Step;
procedure Step_Local;
procedure Step_Returned;
procedure Break_Here;
procedure Break;
procedure Break (Location : String;
Count : Natural;
In_Task : String;
Permanent : Boolean);
procedure Activate_Break;
procedure Activate_Break (Break_List : String);
procedure Remove_Break;
procedure Remove_Break (Break_List : String; Delete : Boolean);
procedure Show_All;
procedure Show_Breakpoints;
procedure Show_Exception_Handling;
procedure Show_Stops_And_Holds;
procedure Show_Stepping;
procedure Show_Tracing;
procedure Show_History;
procedure Context_Control;
procedure Context_Control (Location : String);
procedure Context_Evaluation;
procedure Context_Evaluation (Location : String);
procedure Information_Tasks;
procedure Information_Exceptions;
procedure Information_Rendezvous;
procedure Information_Space;
procedure Put_Selection;
procedure Put_Parameters;
procedure Stack;
procedure Source;
procedure Modify;
procedure Modify (Variable : String; Value : String);
procedure Quit;
procedure Quit (Kill_Job : Boolean; Kill_Debugger : Boolean);
end Debug;
------------------
-- Session menu --
------------------
package Session is
procedure Search_List;
procedure Switches;
procedure Profile;
procedure Profile (Error_Reaction : String;
Line_Width : Natural;
Activity : String;
Log_Filter : String;
Log_Prefixes : String;
Log_File : String;
Remote_Passwords_File : String;
Remote_Sessions_File : String);
procedure Disable_Job;
procedure Disable_Job (Number : Natural);
procedure Enable_Job;
procedure Enable_Job (Number : Natural);
procedure Kill_Job;
procedure Kill_Job (Number : Natural; Session : String := ""); -- ??
procedure Users;
procedure My_Jobs;
procedure All_Jobs;
procedure Machine_Information;
procedure End_Of_Input;
end Session;
package Tools is
procedure Read_Mail;
procedure Send_Mail;
procedure Find_Image;
procedure Image_Directory;
procedure Macro_Begin;
procedure Macro_End;
procedure Macro_Execute;
procedure Macro_Bind_To_Key;
procedure Screen_Push;
procedure Screen_Pop;
procedure Operator_Backup;
procedure Operator_Backup (Start_At : String;
Kind : Backup_Kind;
Tape_Drive : String);
procedure Operator_Verify_Backup;
procedure Operator_Verify_Backup
(Start_At : String; Tape_Drive : String);
procedure Operator_Backup_History;
procedure Operator_Edit_User;
procedure Operator_Edit_User (User_Name : String;
Password : String;
Add_To_Groups : String;
Remove_From_Groups : String;
Create_Mailbox : Boolean);
procedure Operator_Edit_Group;
procedure Operator_Edit_Group (Group_Name : String;
Create : Boolean;
Delete : Boolean;
Add_Users : String;
Remove_Users : String);
procedure Operator_Force_Logoff;
procedure System_Manager_Password_Policy;
procedure System_Manager_Report;
procedure System_Manager_Report (Report_Kinds : String;
Start_Time : String;
End_Time : String;
Result_File : String);
procedure System_Manager_Shutdown;
procedure System_Manager_Shutdown
(At_Time : String;
Reason : String;
Message_To_Send_Periodically : String);
procedure System_Manager_Cancel_Shutdown;
procedure Show_Locks;
procedure Bind_To_Key;
end Tools;
package Help is
procedure Explain_Underline;
procedure On_Command;
procedure On_Key;
procedure On_Keybindings;
procedure On_Help;
end Help;
procedure Load_Image_Palette;
procedure Load_Debug_Palette;
pragma Module_Name (4, 2229);
end Menu_Operations;package Message is
-- Write message in the message window of other user's sessions.
-- Send selects an individual user; Send_All sends to all logged in users.
procedure Send (Who : String; Message : String);
procedure Send_All (Message : String);
pragma Subsystem (Command);
pragma Module_Name (4, 2208);
end Message;with Calendar;
package Network is
procedure Show; -- show all currently open connections.
procedure Close_All; -- close all connections.
procedure Show_Hosts; -- show all known hosts.
procedure Show_Host (Host_Name : String := ""); -- show the named host.
procedure Time (From_Host : in String := "");
-- Display the time of day, as reported by the given host.
function Get_Time (From_Host : String) return Calendar.Time;
function Get_Time_Zone return Integer;
pragma Subsystem (Input_Output, Private_Part => Closed);
pragma Module_Name (4, 3225);
end Network;with System_Utilities;
with Terminal;
package Operator is
procedure Disk_Space;
procedure Create_User (User : String := ">>USER NAME<<";
Password : String := "";
Volume : Natural := 0;
Response : String := "<PROFILE>");
-- create a user with the given password on volume (0 => Most Available)
procedure Delete_User (User : String := ">>USER NAME<<";
Response : String := "<PROFILE>");
-- delete user; Operator capability is required (or privileged mode)
procedure Change_Password (User : String := ">>USER NAME<<";
Old_Password : String := "";
New_Password : String := "";
Response : String := "<PROFILE>");
procedure Create_Session (User : String := ">>USER NAME<<";
Session : String := ">>SESSION NAME<<";
Response : String := "<PROFILE>");
procedure Create_Group (Group : String := ">>GROUP NAME<<";
Response : String := "<PROFILE>");
-- Create the named group. It must currently not exist. It has
-- no initial members.
procedure Delete_Group (Group : String := ">>GROUP NAME<<";
Response : String := "<PROFILE>");
-- Delete the named group. This operation cannot be used to delete the
-- group with the same name as an existent user. Delete_User will
-- get rid of the group associated with a user. Acl entries
-- that refer to a deleted group become inoperative and will be
-- reclaimed during the next access list compaction.
procedure Add_To_Group (User : String := ">>USER NAME<<";
Group : String := ">>GROUP NAME<<";
Response : String := "<PROFILE>");
-- Add the specified user to the specified group.
-- Operator privilege is required to execute this operation.
procedure Remove_From_Group (User : String := ">>USER NAME<<";
Group : String := ">>GROUP NAME<<";
Response : String := "<PROFILE>");
-- Remove the specified user to the specified group.
-- Operator privilege is required to execute this operation.
procedure Display_Group (Group : String := ">>GROUP NAME<<";
Response : String := "<PROFILE>");
-- Display the names of users in the specified group on Current_Output.
procedure Enable_Privileges (Enable : Boolean := True);
function Privileged_Mode return Boolean;
-- If the caller is a member of the predefined group "privileged",
-- calling this procedure actually enables or disables the
-- extra capabilities that such a job can have. General usage is
-- to not enable privileged mode unless it is really needed so
-- as to avoid accidently doing something that would normally be
-- stopped by access control. All tasks in the job become
-- privileged when the mode is enabled. No output is produced
-- by any of these procedures. Failure to acquire privileged mode
-- is indicated only by the absence of the privileges. Privileged_Mode
-- returns false in this case.
procedure Enable_Terminal (Physical_Line : Terminal.Port;
Response : String := "<PROFILE>");
procedure Disable_Terminal (Physical_Line : Terminal.Port;
Response : String := "<PROFILE>");
-- (Dis)allow login on the specified terminal port
procedure Force_Logoff (Physical_Line : Terminal.Port;
Commit_Buffers : Boolean := True;
Response : String := "<PROFILE>");
-- Force a user off of the specified terminal.
-- Try to commit modified buffers if Commit_Buffers is true.
-- Each of these operations requires operator capability.
procedure Set_System_Time (To_Be : String := ">>TIME<<";
Response : String := "<PROFILE>");
-- Requires operator capability.
procedure Shutdown_Warning (Interval : Duration := 3600.0);
-- Note that Interval is rounded to the nearest minute. Less than
-- 30.0 is rounded to 0.
function Get_Shutdown_Interval return Duration;
procedure Archive_On_Shutdown (On : Boolean := True);
function Get_Archive_On_Shutdown return Boolean;
-- Archive_On_Shutdown causes the next shutdown to store internal
-- state in "archive" form, allowing upgrades and conversion of
-- internal data structures. It typically takes several hours to
-- complete a shutdown or restart with archive conversions.
procedure Show_Shutdown_Settings;
procedure Cancel_Shutdown;
procedure Shutdown (Reason : String :=
"COPS"; -- Customer operations
Explanation : String := "Cause not entered");
-- Shutdown the machine. Enter the cause and explanation in the system
-- log, wait for the Shutdown interval to expire, then log users
-- off and shutdown the machine.
-- Enter Reason = "?" to get list of reasons. The shutdown will not
-- happen unless Reason is a legal value.
procedure Explain_Crash;
-- Reads a shutdown cause and explanation from current input and enters
-- these in the machine's error log. Corresponds to the information
-- entered by shutdown.
procedure Limit_Login (Sessions : Positive := Positive'Last);
procedure Show_Login_Limit;
function Get_Login_Limit return Positive;
-- Control over the number of simultaneously active user sessions
procedure Internal_System_Diagnosis;
-- Requires Operator capability
subtype Days is Positive;
procedure Set_Password_Policy
(Minimum_Length : Natural := 0;
Change_Warning : Days := Operator.Days'Last;
Change_Deadline : Days := Operator.Days'Last);
-- Passwords must be at least Minimum_Length characters long.
-- Passwords must be changed periodically. Change_Warning days after the
-- last change, the user will be notified at login that the account
-- password should be changed. Change_Deadline days after the last change,
-- the user will be unable to login without changing the password.
-- The default values introduce no restrictions.
-- Requires Operator capability.
procedure Show_Password_Policy
(For_User : String := System_Utilities.User_Name);
-- Show the current policy along with the expiration dates for the user(s)
-- specified.
function Get_Minimum_Password_Length return Natural;
function Get_Password_Warning return Days;
function Get_Password_Deadline return Days;
-- Return the values last set by Set_Password_Policy.
function Get_User_Warning
(For_User : String := System_Utilities.User_Name) return String;
function Get_User_Deadline
(For_User : String := System_Utilities.User_Name) return String;
-- Return the image of the date on which the Warning (Deadline) for
-- changing the password will be reached. Can be processed by
-- Time_Utilities if necessary to have numeric value. Format is mm/dd/yy.
pragma Subsystem (Os_Commands);
pragma Module_Name (4, 3926);
end Operator;with Machine;
with Simple_Status;
package Program is
subtype Job_Id is Machine.Job_Id;
subtype Condition is Simple_Status.Condition;
procedure Run (S : String := "<SELECTION>";
Context : String := "$";
Response : String := "<PROFILE>");
-- sets root of job_garbage_unit, dangerous to run concurrently in one job
procedure Run_Job (S : String := "<SELECTION>";
Debug : Boolean := False;
Context : String := "$";
After : Duration := 0.0;
Options : String := "";
Response : String := "<PROFILE>");
procedure Create_Job (S : String := "<SELECTION>";
Job : out Job_Id;
Status : in out Condition;
Debug : Boolean := False;
Context : String := "$";
After : Duration := 0.0;
Options : String := "";
Response : String := "<PROFILE>");
-- Run_Job and Create_Job are identical except that Create_Job
-- returns the job number of the job just started and a status indicating
-- success or failure.
--
-- Debug => True starts the debugger on the newly started job
--
-- The following options are defined:
--
-- Output Specifies the name of the new job's output file.
-- Input New job's standard input file.
-- Error New job's error file.
-- File names given are resolved in the directory
-- context of the caller, NOT the Context parameter.
--
-- User Causes the new job to run with the identity
-- of this user. Password must be valid unless
-- running job is privileged. If not specified
-- new job runs with same identity as parent.
--
-- Password Password used in conjunction with User.
--
-- Session Session used in conjunction with User.
function Started_Successfully (Status : Condition) return Boolean;
-- True => Job has been started successfully
procedure Wait_For (Job : Job_Id);
-- Wait until the job specified has terminated.
procedure Change_Identity (To_User : String := "";
Password : String := "";
Options : String := "";
Status : in out Condition);
-- Change the identity of the calling job to the specified
-- user. Password must be supplied and correct unless the
-- caller is privileged. Options specifies additional
-- characteristics to be changed. If To_User is null,
-- the options are processed.
-- Note that only the access control identity is changed.
-- The actual username and session of the job are NOT changed.
-- This operation should never be used to change identity and
-- execute untrusted code. The identity can always be changed
-- back to the original job identity.
-- Options presently defined are:
-- Privileged -- enable privileged mode. The specified user
-- -- must be a member of group PRIVILEGED
-- Privileged => False -- disable privileged. No effect if caller
-- -- was not already privileged.
-- Restore_Identity -- Change the identity back to the original
-- -- identity of the job. Password is not
-- -- required to do this.
function Current (Subsystem : String := ">>SUBSYSTEM NAME<<";
Unit : String := ">>PROCEDURE NAME<<";
Parameters : String := "";
Activity : String := "<ACTIVITY>") return String;
-- Constructs a procedure call suitable for Run or Run_Job that references
-- the appropriate view, has the appropriate quotes, etc. Unit name is
-- the Ada name to be called; it will be found anywhere in the
-- view. If the procedure being called has parameter they may be
-- provided. If the current view of !Subsystem is Rev8_4_0 and package
-- View is in the Commands directory, then:
--
-- Current ("!Subsystem", "View.Initial",
-- "(P1 => ""!New_Tool"", P2 =>1)") returns:
--
-- "!Subsystem.Rev8_4_0.Units.Commands".View.Initial
-- (P1 => "!New_Tool", P2 => 1);
pragma Subsystem (Commands);
pragma Module_Name (4, 3930);
end Program;with Directory;
package Queue is
procedure Print (Name : String := "<IMAGE>";
Options : String := "<DEFAULT>";
Banner : String := "<DEFAULT>";
Header : String := "<DEFAULT>";
Footer : String := "<DEFAULT>");
procedure Print_Version (The_Version : Directory.Version;
Options : String := "<DEFAULT>";
Banner : String := "<DEFAULT>";
Header : String := "<DEFAULT>";
Footer : String := "<DEFAULT>");
--
-- The Print and Print_Version procedures are the provided user interfaces
-- for sending files to a printer. They queue object(s) to be printed and
-- echo request IDs in the message window with corresponding objects.
--
--
-- NOTE : if a value is not specified for a parameter (<DEFAULT> is
-- indicated) then the value supplied in the session switch
-- file is used; if a session switch is not defined or
-- unavailable then the default specified here is used.
--
-- BANNER: String to be used on the banner page
-- (truncated at 11 characters), user's id is the default
-- Specifying the null string ("") will inhibit the generation
-- of a banner page.
--
-- HEADER: User supplied page header; default is none.
--
-- FOOTER: User supplied page footer; default is none.
-- (see R1000 documentation for headers or footers
-- containing Line-Feeds or exceeding Width characters)
--
-- OPTIONS: A form parameter for setting various formatting and
-- spooling options; default is "Format=>(Wrap, System_Header").
--
--
-- The Currently available Options and semantic rules for these options are
-- described at the end of this package and in detail in the documentation.
--
procedure Cancel (Request_Id : Positive);
-- cancels a request by ID obtained from Print or Queue
-- Extreme measures for wedged spooler
procedure Kill_Print_Spooler;
procedure Restart_Print_Spooler;
-- The remaining procedures do NOT use any session switches.
subtype Class_Name is String;
All_Classes : constant Class_Name := "all";
All_Spooler_Devices : constant String := "all";
-- The following procedures provide information on the state
-- of the print spooler.
procedure Display (Class : Class_Name := "all");
-- print the current contents of the Queue
procedure Classes (Which : Class_Name := "all";
Show_Devices : Boolean := True);
-- Display information about one or all classes
procedure Devices (Which : String := "all";
Show_State : Boolean := True;
Show_Classes : Boolean := True);
-- Display information about one or all devices
-- The following procedures are used to define queues in the spooler.
procedure Create (Class : Class_Name := "");
procedure Destroy (Class : Class_Name := ""; Reroute : Class_Name := "");
-- Create/Destroy a class.
-- When a class is destroyed any requests in that class are rerouted to
-- the class specified (the default class if none is specified).
procedure Default (Class : Class_Name := "");
-- set Default Class or print current Default (if null string provided)
procedure Add (Device : String := ""; Options : String := "XON_XOFF");
-- Options :
-- XON_XOFF, RTS, DTR indicate what flow control is to be used.
-- Host => name indicates that a telnet connection is to be used
-- If Host is given, Socket may be specified: Socket => (0, 23).
--
-- Options can also have the value FTP. In this case, Device is
-- the name of a file whose first line is a host name, whose
-- second line is a directory name, whose third line is a suffix
-- to append to each file name, and whose fourth line is the
-- name of a remote passwords file. Each print request will
-- be transferred to the specified host and directory using an
-- FTP login for the host from the specified remote passwords file.
-- The directory name in the file must have any trailing punctuation
-- so that a simple filename can be concatenated to it. A log file
-- is created in !Machine.Queues.Ftp under the device name (which
-- is the simple name of the device file) to record any FTP
-- problems.
procedure Remove (Device : String := ""; Immediate : Boolean := False);
-- Associate/Disassociate a device with the print spooler.
procedure Register (Device : String := ""; Class : Class_Name := "");
procedure Unregister (Device : String := ""; Class : Class_Name := "");
-- Associates/disassociates a class and a device.
-- If a class is not associated with a device then items spooled to that
-- class can not be printed.
procedure Enable (Device : String := "all");
procedure Disable (Device : String := ""; Immediate : Boolean := False);
-- Allows/Disallows printing on device(s)
-------------------------------------------------------------------------------
--
-- Description of the Options available for Print and Print_Version.
--
-- The following is a list of legal options.
--
-- BANNER_PAGE_USER_TEXT => text
--
-- Text appears on the banner page (if one is generated) after the
-- "Banner".
--
-- CLASS => class name
--
-- Class to which printout is to be queued. (default is <DEFAULT>)
--
-- COPIES => number
--
-- Number of copies of the printout (default is 1)
--
-- LENGTH => number
-- Number of printed lines available on a page (default is 60).
--
-- NOTIFY => Mail | MESSAGE | None
--
-- Type of notification desired upon completion of the print request.
--
-- ORIGINAL_RAW => true | FALSE
--
-- DO NOT make a copy of the file to be printed. Notification is set
-- to Message and each file is spooled separately with a banner page.
-- Class must NOT be Remote.
--
-- PostScript => ( <PostScript_Options> )
--
-- Specify to print using PostScript rules. PostScript options and
-- functionality are described below. The null options string, (),
-- invokes the PostScript printer with default parameters.
--
-- FORMAT => ( <Format_Options> )
--
-- The printer is to be treated as a conventional Ascii device with
-- the specified options, which are described below. FORMAT with the
-- null options string, (), is the default unless other options are
-- specified.
--
-- RAW => true | FALSE
--
-- DO NOT interpret the input. This option can be useful for
-- preformatted text or binary data.
--
-- SPOOL_EACH_ITEM => true | FALSE
-- Spool each file as a separate job.
--
-- Exactly one of the Format, Original_Raw, PostScript, or Raw can be supplied
-- for any print request. If any of these are specified in the Options
-- parameter, then the corresponding session switch is ignored.
--
-- <Format_Options>
-- The following is a list of legal <format_options>. Unless
-- otherwise specified, the Boolean options are assumed to be False.
--
-- NUMBERING => true | FALSE
--
-- Provide line numbering.
--
-- SYSTEM_HEADER => number
--
-- Produce a system page header on each page.
--
-- TAB_WIDTH => number
--
-- Number of spaces to replace a tab character (Ascii.HT) with
-- (default is 8). 0 causes tabs to be sent to the printer.
--
-- TRUNCATE => true | FALSE
--
-- Truncate lines longer than Width.
--
-- WIDTH => number
--
-- Number of characters to be printed on a line (default is 80).
--
-- WRAP => true | FALSE
--
-- Wrap lines longer than Width.
--
--
--
-- <PostScript_Options>
--
-- FORMAT => PostScript | plain_text | fancy | letter | image | AUTOMATIC
--
-- Broadly specifies how the file is to be printed, whether the file
-- to be printed is a PostScript program (such as generated by a text
-- formatter) or plain text that must be prepared for printing.
--
-- AUTOMATIC is the default, in which case the file is looked at to
-- determine it's type. If the file begins with a % it is processed
-- as a PostScript program, if it begins with Ascii.Nul it is printed
-- as an IMAGE, otherwise it is processed as PLAIN_TEXT.
--
-- LETTER format is similar to PLAIN_TEXT except that the defaults for
-- TWOUP, BORDER, DATE, FILENAME, WRAP, and NUMBER are all False.
--
-- FANCY format is similar to PLAIN_TEXT, except that Ada
-- reserved words are emboldened and comments are Italicized.
--
-- The following options apply to both PostScript and Plain_Text files.
--
-- STATS => TRUE | false
--
-- Causes statistics on the size of files and their print speed to be
-- included in job messages.
--
-- FLOW => true | FALSE
--
-- By default (FLOW=false), each file printed starts on a new sheet
-- of paper. When FLOW is true, however, a file will start on the
-- right half of a sheet if not occupied by the previous file.
-- Setting FLOW to true forces TWOUP = true and REVERSED = false.
--
-- REVERSED => TRUE | false
--
-- If true, the default, the pages are reversed before printing so
-- that the stack of pages in the printer's output tray are in the
-- correct order with the first page on top. If false, the pages
-- will be printed in the order they appear in the file.
--
-- CHATTY => TRUE | false
--
-- If true, the default, messages will be generated in the message
-- window before accessing each file in the print request When false,
-- PostScript issues a message only when all files have been printed
-- and under error conditions.
--
-- PAGES = <integer> [..<integer>]
--
-- Specifies the range of pages to be printed. The first page in the
-- file is numbered 1. The default is to print all pages in the
-- file. If only one integer is given, that one page is printed.
--
-- HEADER => true | FALSE
--
-- If true, a header page is printed that identifies the file that is
-- being printed and the circumstances of its printing.
--
-- TWOUP => TRUE | false
--
-- If true, two file pages are printed per sheet of printer paper.
-- The image of each page is 2/3 the size of a full page. The
-- default for this option for plain text files is true; for
-- PostScript files, it is false.
--
-- OUTLINES => TRUE | false
--
-- If true, a solid box is drawn around the text for each page.
-- BORDER is an alternative name for this option. The default for
-- this option for PLAIN_TEXT files is true; for PostScript files, it
-- is false.
--
-- DATE => true | false
--
-- If true, the time and date at the time of queueing is printed in
-- the lower-left corner of each page, outside the outline box if
-- present. The default for this option for plain text files is
-- true; for PostScript files, it is false;
--
-- FILENAME => true | false
--
-- If true, the full name of the file is printed in the upper-left
-- corner of each page, outside the outline box if present. The
-- default for thisoption for plain text files is true; for
-- PostScript files, it is false;
--
-- The following options apply to PLAIN_TEXT files only. All combinations are
-- valid.
--
-- NUMBER => TRUE | false
--
-- If true, a page number is printed in the upper right corner of
-- each page, outside the outline box, if present. The numbering
-- starts again at 1 for each file printed.
--
-- WIDE => true | FALSE
--
-- If true, each page is printed in landscape orientation, i.e., with
-- the lines of text parallel to the longer side of the page.
--
-- RULES => true | FALSE
--
-- If true, faint dashed lines are drawn every other line of the
-- output.
--
-- SIZE = <integer>
-- SPACING = <integer>
--
-- Specifies the point-size of the typeface used to generate the
-- output and the vertical spacing of each line measured in points.
-- These point sizes determine the number of lines per page and the
-- number of characters per line according to the following formulae:
--
-- For the WIDE format:
--
-- Lines/Page = 540 / Spacing
-- Characters/Line = 1200 / Size
--
-- For the ~WIDE (narrow) format:
--
-- Lines/Page = 720 / Spacing
-- Character/Line = 900 / Size
--
-- The default SPACING is SIZE + 1; The default SIZE is 11 (yielding
-- a SPACING of 12). In ~WIDE format this allows for 60 lines of
-- 81-character lines.
--
-- FONT = <font name>
--
-- Specifies the typeface to be used in printing the file. Any
-- built-in PostScript font may be specified. The default is
-- /Courier-Bold. If <font-name> begins with a '/', PostScript
-- assumes the font is already resident and uses the <font name> to
-- define the font to use. If <font name> does not begin with '/',
-- PostScript assumes it is the name of a file containing PostScript
-- for a downloadable font. This file is sent to the printer before
-- any files are processed by PostScript. The simple name of the
-- file, capitalized as it appears in the font option, is used to set
-- the font for the plain_text file.
--
-- CHOP => true | FALSE
--
-- If false, the default, a line longer than the line length defined
-- by the above formulae is broken at the rightmost blank within the
-- line and the extra text is printed on the next line justified to
-- the right margin. If true, long input lines will be clipped at
-- the boundaries of the imageable area (7.5 x 10.0 inches).
--
-- The following options affect the IMAGE format:
--
-- X = number
-- Y = number
--
-- Specifies, in inches, the coordinates of the lower left corner of
-- the first image. The default coordinate is (0.25, 0.25), a point
-- 1/4 inch from the lower left corner of the paper.
--
-- DX = number
-- DY = number
--
-- Specifies the offset from the previous image coordinate to the
-- coordinate for the next image. Dx is added to the X coordinate
-- for each successive image until the resulting coordinate would be
-- outside the bounds of the paper, at which time X is reset to its
-- original value and Dy is added to the Y coordinate. When the Y
-- coordinate exceeds the bounds of the paper, a new page is started
-- at the original X, Y coordinate.
--
-- WIDTH = number
-- HEIGHT = number
--
-- Specifies the maximum width and height allowed for the image. The
-- default values specify a full page image.
--
-- DISTORT => true | FALSE
--
-- If true, the image will be magnified so that the image fills
-- exactly the box defined by width and height. If false, the image
-- will be magnified as large as possible while retaining the aspect
-- ratio of the image.
--
-- ASPECT => number
--
-- Overrides the aspect ratio of the image.
--
-- CAPTION => text
--
-- Text to be rendered below the printed image.
--
-- PROLOG => text
-- EPILOG => text
--
-- PostScript code to be sent before and after each image. The
-- following regards action taken on files when the PostScript option
-- is specified and a list of legal <PostScript_options>.
--
-- The following "commands" will be regonized when embedded in an input file
-- when using a PostScript printer. These commands must begin in the first
-- column of a line and must be capitalized as shown above.
--
-- %%INCLUDE naming-expression
--
-- Recognized in all formats except Image. Causes the files named in
-- the expression to be opened and processed as if they were part of
-- the input file. %%INCLUDEs can be nested to 10 deep.
--
-- %%ASCII naming-expression
--
-- Recognized in PostScript format only. Causes the named files to
-- be opened and sent to the destination without further
-- interpretation by PostScript (nested commands are ignored).
--
-- %%BINARY naming-expression
--
-- Recognized in PostScript format only. Causes the named files to
-- be opened and sent to the destination as strings of hexadecimal
-- numbers. The %%BINARY command should be preceded by PostScript
-- code that will prepare the printer to receive hexadecimal data.
--
-------------------------------------------------------------------------------
pragma Subsystem (Os_Commands);
pragma Module_Name (4, 3922);
end Queue;package Remote is
procedure Run (Machine : String := ">>machine_name<<";
Command : String := "<IMAGE>";
File_Context : String := "$";
Run_Context : String := "<DEFAULT>";
Options : String := "";
Response : String := "<PROFILE>");
-- Run a command on another machine.
-- The default naming context in which the command will run is
-- given by Run_Context. <DEFAULT> means use the same context
-- as that on the current machine.
-- If that doesn't exist on the target ! is used.
-- File_Context is the default context for opening files
-- on the target.
---------------------------------------------------------------------------
procedure Show (Machine : String := ">>machine_name<<";
Object_Name : String := "<CURSOR>";
Response : String := "<PROFILE>");
-- type the contents of an object which is on another machine.
---------------------------------------------------------------------------
pragma Subsystem (Archive);
pragma Module_Name (4, 3918);
end Remote;package Remote_Passwords is
-- The commands in this package can be used to add, change, delete,
-- and display entries in a remote passwords file. By default,
-- these commands access the remote passwords file for the current
-- session. The For_Session parameter in these commands allows you
-- to specify a non-default session; in this case, the operation
-- applies to the remote passwords file of the given session.
--
-- A remote passwords file is a text file that specifies
-- the username and password to be used when accessing a remote
-- host. This file may contain one or more entries of the following
-- form:
--
-- HOST_NAME USERNAME PASSWORD_VALUE
--
-- HOST_NAME must identify a machine to which the user has access.
-- USERNAME must be a valid username on the specified machine.
-- PASSWORD_VALUE must be one of the following:
--
-- "Ada-style_quoted_string"
-- <PROMPT>
-- <DES:hexadecimal_string>
-- ""
--
-- For example, a remote passwords file might contain entries such
-- as the following:
--
-- machine1 username1 password1
-- machine1 "username1" "password1"
-- machine2 guest ""
-- machine3 username3 <PROMPT>
-- machine4 operator <DES:29A1EB449C1A03F6>
--
-- In this example, the two entries for machine1 are equivalent.
-- The entry for machine2 provides for a guest user who has no
-- password; the entry for machine3 causes username3 to be prompted
-- for a password; the entry for machine4 indicates that the
-- password for operator has been encrypted using DES.
type Encryption_Method is (None, Hex, Des);
--
-- Represents the forms of encryption that can be applied to the
-- passwords entered into the remote passwords file. The Encryption
-- parameter in these commands allows you to specify the type of
-- encryption to be used when a password is added or changed. The
-- value None causes the clear text password to be entered without
-- encryption.
procedure Create
(New_File : String := ">>REMOTE PASSWORDS FILE<<";
Source_File : String := "";
Source_Password : String := "<PROMPT>";
Encryption : Encryption_Method := Remote_Passwords.Des;
Response : String := "<PROFILE>");
--
-- Creates a new remote passwords file using Source_File and
-- Source_Password to initialize the contents of the file. After
-- Source_File has been decrypted with Source_Password, New_File is
-- created and populated with encrypted source entries for the
-- current user as specified by the Encryption parameter. Any
-- source entries that cannot be decrypted by Source_Password are
-- omitted from New_File.
procedure Set_Default (Existing_File : String := "<IMAGE>";
For_Session : String := "";
Response : String := "<PROFILE>");
--
-- Establishes Existing_File as the default remote passwords
-- file for For_Session. This information is stored in the
-- Profile.Remote_Passwords switch of the session switch file
-- associated with For_Session. When no switch file exists, it
-- is created before storing the value.
procedure Add (New_Hostname : String := ">>REMOTE HOST<<";
New_Username : String := ">>REMOTE USER<<";
New_Password : String := "<PROMPT>";
Encryption : Encryption_Method := Remote_Passwords.Des;
For_Session : String := "";
Response : String := "<PROFILE>");
--
-- Adds an entry for New_Hostname to the remote passwords file of
-- the calling user. When an entry for New_Hostname already exists,
-- an error message is generated and the remote passwords file is
-- left unchanged.
procedure Change (Existing_Hostname : String := ">>REMOTE HOST<<";
New_Username : String := ">>REMOTE USER<<";
New_Password : String := "<PROMPT>";
Encryption : Encryption_Method
:= Remote_Passwords.Des;
For_Session : String := "";
Response : String := "<PROFILE>");
--
-- Changes the entry for Existing_Hostname in remote passwords file
-- of the calling user. When the entry for Existing_Hostname does
-- not exist, it is Add'ed.
procedure Delete (Existing_Hostname : String := ">>REMOTE HOST<<";
For_Session : String := "";
Response : String := "<PROFILE>");
--
-- Removes the entry for Existing_Hostname from the remote passwords
-- file of the calling user. When an entry for Existing_Hostname
-- does not exist, a warning message is generated.
procedure Show_Encryption
(Of_Password : String := "<PROMPT>";
Encryption : Encryption_Method := Remote_Passwords.Des);
--
-- Displays the encrypted form of Of_Password for the calling user
-- in the message window. The value displayed is identical to what
-- would be directly reflected in the remote passwords file if the
-- same password was used in the file manipulation operations that
-- are listed below.
procedure Update (Old_Password : String := "<PROMPT>";
For_Session : String := "";
Response : String := "<PROFILE>");
--
-- Updates the remote passwords file after the user's Rational
-- password has been changed.
---------------------------
-- Remote Passwords File --
---------------------------
function Get_Default (For_Session : String := "";
Response : String := "<WARN>") return String;
--
-- Returns a naming expression for the default remote passwords
-- file for For_Session. When errors occur while resolving this
-- file, the value "<>" is returned.
pragma Subsystem (Os_Commands);
pragma Module_Name (4, 4300);
end Remote_Passwords;with Machine;
package Scheduler is
subtype Job_Id is Machine.Job_Id;
subtype Cpu_Priority is Natural range 0 .. 6;
subtype Milliseconds is Long_Integer;
procedure Disable (Job : Job_Id);
procedure Enable (Job : Job_Id);
function Enabled (Job : Job_Id) return Boolean;
function Get_Cpu_Priority (Job : Job_Id) return Cpu_Priority;
type Job_Kind is (Ce, Oe, Attached, Detached, Server, Terminated);
function Get_Job_Kind (Job : Job_Id) return Job_Kind;
type Job_State is (Run, Wait, Idle, Disabled, Queued);
function Get_Job_State (Job : Job_Id) return Job_State;
-- returns the current state of job.
-- RUN: the job is currently runnable
-- WAIT: the job is runnable but being withheld by the scheduler.
-- IDLE: the job isn't using cpu time and has no unblocked tasks.
-- DISABLED: an external agent has disabled the job from running.
-- QUEUED: the job is DETACHED and must wait for another to complete.
function Get_Cpu_Time_Used (Job : Job_Id) return Milliseconds;
-- returns the number of milliseconds of cpu time used by the job.
-- belongs on the previous page, put here for compatability reasons
function Disk_Waits (Job : Job_Id) return Long_Integer;
-- returns the number of disk_waits the job has done since last initialized
function Working_Set_Size (Job : Job_Id) return Natural;
-- returns the number of pages in the job's working set.
subtype Load_Factor is Natural;
-- for run queues, number of tasks * 100
procedure Get_Run_Queue_Load (Last_Sample : out Load_Factor;
Last_Minute : out Load_Factor;
Last_5_Minutes : out Load_Factor;
Last_15_Minutes : out Load_Factor);
-- number of runnable tasks * 100
procedure Get_Disk_Wait_Load (Last_Sample : out Load_Factor;
Last_Minute : out Load_Factor;
Last_5_Minutes : out Load_Factor;
Last_15_Minutes : out Load_Factor);
-- number of tasks waiting for a page on the disk wait queue * 100
procedure Get_Withheld_Task_Load (Last_Sample : out Load_Factor;
Last_Minute : out Load_Factor;
Last_5_Minutes : out Load_Factor;
Last_15_Minutes : out Load_Factor);
-- returns the average number of tasks withheld from running by
-- the scheduler * 100. In this call LAST_SAMPLE is the number of tasks
-- held at the last 100ms scheduling cycle.
procedure State;
-- print scheduler state
procedure Display (Show_Parameters : Boolean := True;
Show_Queues : Boolean := True);
-- display current scheduler state and queues
type Job_Descriptor is
record
The_Cpu_Priority : Cpu_Priority;
The_State : Job_State;
The_Disk_Waits : Long_Integer;
The_Time_Consumed : Milliseconds;
The_Working_Set_Size : Natural;
The_Working_Set_Limit : Natural;
The_Milliseconds_Per_Second : Natural;
The_Disk_Waits_Per_Second : Natural;
The_Maps_To : Job_Id;
The_Kind : Job_Kind;
The_Made_Runnable : Long_Integer;
The_Total_Runnable : Long_Integer;
The_Made_Idle : Long_Integer;
The_Made_Wait : Long_Integer;
The_Wait_Disk_Total : Long_Integer;
The_Wait_Memory_Total : Long_Integer;
The_Wait_Cpu_Total : Long_Integer;
The_Min_Working_Set_Limit : Long_Integer;
The_Max_Working_Set_Limit : Long_Integer;
end record;
function Get_Job_Descriptor (Job : Job_Id) return Job_Descriptor;
-- use to get a consistent snapshot of a job's statistics.
generic
with procedure Put (Descriptor : Job_Descriptor);
procedure Traverse_Job_Descriptors (First, Last : Job_Id);
-- use to get a consistent, efficient snapshot of a range of
-- job's statistics.
procedure Set (Parameter : String := ""; Value : Integer);
function Get (Parameter : String) return Integer;
-- Programmatic versions of set and display
-- initial parameters Default Units
-- CPU_Scheduling 1 1 or 0 (true or false)
-- Percent_For_Background 10 %
-- Min_Foreground_Budget -250 milliseconds (-5000..0)
-- Max_Foreground_Budget 250 milliseconds (0..5000)
-- Withhold_Run_Load 130 load * 100
-- Withhold_Multiple_Jobs 0 1 or 0 (true or false)
-- Memory_Scheduling 1 1 or 0 (true or false)
-- Environment_Wsl 11000 pages
-- Min_Ce_Wsl 400 pages
-- Max_Ce_Wsl 1000 pages
-- Min_Oe_Wsl 250 pages
-- Max_Oe_Wsl 2000 pages
-- Min_Attached_Wsl 50 pages
-- Max_Attached_Wsl 2000 pages
-- Min_Detached_Wsl 50 pages
-- Max_Detached_Wsl 4000 pages
-- Min_Server_Wsl 400 pages
-- Max_Server_Wsl 1000 pages
-- Daemon_Wsl 200 pages
-- Wsl_Decay_Factor 50 pages
-- Wsl_Growth_Factor 50 pages
-- Min_Available_Memory 2048 pages
-- Page_Withdrawl_Rate 1 n*640 pages/sec (n in 0..64)
-- Disk_Scheduling 1 1 or 0 (true or false)
-- Max_Disk_Load 250 Load_Factor
-- Min_Disk_Load 200 Load_Factor
-- Foreground_Time_Limit 60 seconds
-- Background_Streams 3
-- Stream_Time N 2,5,20 minutes
-- Stream_Jobs N 3,0,0 jobs
-- Strict_Stream_Policy 0 1 or 0 (true or false)
procedure Set_Job_Attribute (Job : Job_Id;
Attribute : String := "Kind";
Value : String := "Server");
function Get_Job_Attribute
(Job : Job_Id; Attribute : String := "Kind") return String;
-- These interfaces exist to deal with ongoing changes to scheduler
-- characteristics without requiring new procedures.
--
-- The default parameters to Set_Job_Attributes make the indicated job
-- a server.
--
-- See the documentation for other attributes.
procedure Set_Wsl_Limits (Job : Job_Id; Min, Max : Natural);
procedure Get_Wsl_Limits (Job : Job_Id; Min, Max : out Natural);
procedure Use_Default_Wsl_Limits (Job : Job_Id);
-- Each class of job has a default for working set min and max.
-- Set_Parameter lets you change the default value. Set_Wsl_Limits lets
-- you override the default for a specific job. Use_Default_Wsl_Limits
-- restores the values to the defaults, cancelling any prior Set_Wsl_Limits
-- call.
-- Get_Wsl_Limits returns the current values for a specific job.
-- Min and Max specify the range (in number of pages) in which the
-- working set limit is set. The scheduler chooses the working set
-- limit based on prevailing conditions on the machine. If Min and
-- Max are the same, the a fixed limit is specified.
-- Min must be less than or equal to Max and Max less than the memory size.
-- Error messages are sent to an output window in the case of errors.
-- No message of any kind if success.
pragma Subsystem (Os_Commands);
pragma Module_Name (4, 3923);
end Scheduler;package Search_List is
-- Conceptually a search list is a sequence of component names of
-- libraries. A component name could have wild characters, and would
-- therefore resolve to many libraries. The resolution of a name
-- depends on the resolution of the libraries, order being important.
-- Furthermore, the resolution of a component name or an Ada name
-- depends on the context in which such resolution is done. For
-- instance, the component name "$" meaning enclosing library resolves
-- to different libraries depending on the current context.
-- A separate image comes up for each Edit with different parameters.
-- Most commands take in defaulted Session and User parameters. The
-- defaults refer to the present user and session.
procedure Display (Session : String := ""; User : String := "");
-- Displays the Session Search List Components in a text-io image.
procedure Display_Libraries;
-- Displays the resolution of all the Libraries of the Search List
-- in the present context in a text-io image.
procedure Show_List (Session : String := ""; User : String := "");
-- Shows the Session Search List
procedure Show_Item (Component : String := "<CURSOR>");
-- Displays the library indicated by a Search List component provided it
-- resolves to a unique library. By default, displays the library at
-- the cursor.
procedure Set_Up (Component : String := ">>SEARCH LIST<<";
Session : String := "";
User : String := "");
-- Initialize Search List. Replaces entire previous contents.
procedure Reset_To_System_Default
(Session : String := ""; User : String := "");
-- Resets to system default search list.
procedure Add (Component : String := ">>LIBRARY NAME<<";
Position : Integer := Integer'Last;
Session : String := "";
User : String := "");
-- Adds Component in the indicated Position in the Search
-- List Components image. If defaulted, and cursor is on the
-- Search List image, then that is the location of the addition
-- Otherwise, addition is at end.
procedure Replace (New_Component : String := ">>LIBRARY NAME<<";
Old_Component : String := "<SELECTION>";
Session : String := "";
User : String := "");
-- Replace Old_Component (the component indicated by selection is the
-- default) by New_Component in Search List image.
procedure Delete (Component : String := "<SELECTION>";
Session : String := "";
User : String := "");
-- Remove Component (the component indicated by the current selection is
-- the default) from the Search List image.
procedure Release;
-- Removes current image from the screen
procedure Save (File_Name : String := ">>FILE NAME<<";
Session : String := "";
User : String := "");
-- Save the search list of the given user's session
procedure Revert (File_Name : String := "";
Session : String := "";
User : String := "");
-- Revert the search list for the given user's session from the named
-- file. If the file name is defaulted, the search list is reverted
-- from the permanent search list maintained for this user's session
pragma Subsystem (Commands);
pragma Module_Name (4, 3939);
end Search_List;package Switches is
-- This is the command-level interface to the Switch file facility
subtype File_Name is String;
-- An unambiguous Directory string name for a switch file or a
-- Directory or World. In the latter case, the file asscoiated with
-- that Directory or World is implied.
Default_File : constant File_Name := "";
-- The default file is the selected object if it is a switch file,
-- otherwise it is the switch file associated with the current
-- enclosing library.
subtype Composite_Name is String;
-- an expanded Ada name whose prefix is a processor and whose simple
-- name is a switch of that processor. (If the switch name is unique,
-- the processor name can be omitted.)
-- "Semantics.Ignore_Minor_Errors", "Cg.Enable_Environment_Debugger"
subtype Value_Image is String;
-- Processor/Switch dependent. Will follow Ada conventions where
-- possible. E.g. the value images of Boolean valued switches are "true"
-- and "False"
subtype Specification is String;
-- A specification of the settings for selected switches in the form of
-- a sequence of Ada assignment statements. The lefthand side of the
-- assignment is the name of the switch and the righthand side is the
-- image of the value to be assigned to that switch.
-- e.g.,
-- "Ignore_Minor_Errors := true; Cg.Enable_Environment_debugger := false;"
procedure Define (File : File_Name := ">>SWITCH FILE<<";
Response : String := "<PROFILE>");
-- Creates an empty switch file with the given name. (File must not
-- denote an existing object.)
procedure Associate (File : File_Name := "<SELECTION>";
Library : String := "<IMAGE>";
Response : String := "<PROFILE>");
-- The specified File is associated with the given Library.
-- Association is by-reference. Any subsequent changes to the specified
-- File will be reflected immediately in the associated library.
function Associated (Library : String := "<IMAGE>") return File_Name;
-- Returns the name of the switch file associated with the given Library.
-- Returns the null string if no switch file has been asociated.
procedure Set (Spec : Specification := ">>SWITCHES<<";
File : File_Name := "<SWITCH>";
Response : String := "<PROFILE>");
-- In the given switch file, the values of the switches named in the
-- specification are updated to the values in that spec.
procedure Display (Names : Composite_Name := "@.@";
File : File_Name := "<SWITCH>";
Response : String := "<PROFILE>");
-- The switches in the given file whose names match the wildcard Names
-- specification are listed to the current output file.
procedure Edit (File : File_Name := "<SWITCH>");
-- Brings up a new Switch Display Window containing the contents of the
-- specified file. This window becomes the current Switch Display Window
procedure Visit (File : File_Name := "<SWITCH>");
-- Changes the current Switch Display Window to display the contents of
-- the specified switch File. The existing contents are committed
-- before the new file is displayed. A new Switch Display Window is
-- created if none have yet been created by the user.
procedure Insert (Spec : Specification := ">>SWITCHES<<");
-- The switch values displayed in the current Switch Display Window are
-- changed as indicated. (Generated in response to Object."I" on a
-- Switch Display Window)
procedure Change (Image : Value_Image := ">>SWITCH VALUE<<");
-- The highlighted switch in the current Switch Display Window is
-- changed to the value of the given image. (Generated in response to
-- Object."Z" on a Switch Display Window.)
procedure Write (File : File_Name := ">>SWITCH FILE<<");
-- The contents of the Current Switch Display Window are copied to the
-- specified switch file.
procedure Create (File : File_Name := ">>SWITCH FILE<<";
Category : Character := 'L';
Response : String := "<PROFILE>");
-- Creates an empty switch file of the specified Category with the
-- given name. File should not exist. If it exists and is a File
-- object, a new, empty version will be created of the indicated
-- category.
Of_Session : constant File_Name := "<SESSION>";
-- Switch File_Name used to denote the switches asociated with the
-- current session.
Of_Library : constant File_Name := "<SWITCH>";
-- Switch File_Name used to denote the switches asscoiated with the
-- enclosing library.
procedure Edit_Session_Attributes;
-- Equivalent to Edit (Switches.Of_Session);
procedure Dissociate (Library : String := "<IMAGE>";
Response : String := "<PROFILE>");
-- Sever the association between the specified library and any switch
-- file.
pragma Subsystem (Commands);
pragma Module_Name (4, 3934);
end Switches;package System_Backup is
subtype Id is Natural;
type Kind is (Full, Primary, Secondary);
-- Full backup is self-sufficient
-- Primary incremental is a differential from last Full backup
-- Secondary incremental is a differential from last Primary
procedure Backup (Variety : Kind := System_Backup.Full);
-- Take a backup of kind Variety.
procedure History (Entry_Count : Positive := 10;
Full_Backups_Only : Boolean := False;
Tape_Information : Boolean := False);
-- print a list of Entry_Count previous backups. Full_Backups_Only
-- implies showing only Full backups. Tape_Information implies a list
-- of tapes involved in each.
generic
with procedure Backup_Starting (Is_Full : Boolean);
with procedure Backup_Finishing (Was_Successful : Boolean);
procedure Backup_Generic (Variety : Kind; Wait_Until : String);
-- Complete form of Backup.
--
-- Backup starts at the time specified in wait_until. The tape is mounted
-- now, then Backup pauses until the time specified. Backup_Starting
-- is then called, the backup happens, then Backup_Finishing is called.
--
-- The formal procedures are provided to allow setting up the machine for
-- a backup at the last moment. Usually used to alter scheduling
-- parameters and the like.
pragma Subsystem (Os_Commands);
pragma Module_Name (4, 3924);
end System_Backup;package Tape is
procedure Rewind (Drive : Natural := 0);
procedure Unload (Drive : Natural := 0);
procedure Read_Mt (Drive : Natural := 0);
procedure Write_Mt (File : String := "<SELECTION>";
Indirect : Boolean := True;
Drive : Natural := 0);
procedure Read (Volume : String;
Directory : String := "$";
Options : String := "R1000 Add_New_Line";
To_Operator : String := "Thank You";
Response : String := "<PROFILE>");
-- The specified volume is mounted and all files are read into the
-- given directory.
-- Options are:
-- FORMAT = R1000 | MV | VAX/VMS
-- ADD_NEW_LINE
-- Add a line terminator following each record read from tape.
-- Without this option, bytes are copied from tape without
-- interpretation or modification.
-- Notes on mapping of tape names to R1000 file names
--
-- The file name from the tape is processed by replacing strings
-- of non-alpha-numeric characters with a single '_'. Then,
-- if the name ends with an '_', the character 'B' is appended
-- to the name. If the name contains no alpha-numeric
-- characters, a name derived from the user name and time is generated.
procedure Write (Files : String := "$@";
Volume : String := "";
Options : String := "R1000 Text_Files";
To_Operator : String := "Thank You";
Response : String := "<PROFILE>");
-- The specified Volume is mounted and the specified files are
-- written to the volume.
-- The To_Operator string is displayed to the operator when the
-- request to mount the tape is made.
-- Options are:
-- Text_Files If Text_Files is specified, the file is assumed
-- to contain only characters, line_terminators,
-- page_terminators, etc. Each line of the file
-- is written to a record on the tape. Lines are
-- read according to the same rules as
-- Text_Io.Get_Line.
-- Label an optional part of the label written
-- to the volume header.
-- Format Target system (no abbreviations):
-- R1000, MV, or VAX/VMS
-- [Default: R1000]
-- Record_Format Ansi record format:
-- FIXED_LENGTH, VARIABLE_LENGTH or SPANNED
-- [Default: VARIABLE_LENGTH]
-- Record_Length A positive integer. [Default: 512]
-- Block_Length A positive integer. [Default: 2048]
-- The file name that goes on the tape is generated as follows:
--
-- First, if the object is an Ada Unit, then "V_" or "B_" are prepended
-- to the name if the unit is an Ada spec or body, respectively.
-- Then, '_' characters in the name are removed. One exception
-- to this is that if the name ends in "_xyz", that underscore is
-- replaced with '.', yielding a filename that will end in ".xyz".
-- VAX/VMS bound file names are shortened to 9 characters; others
-- are shortened to 17 characters. If, after removing '_' characters,
-- the name is too long, vowels are removed starting at the right end
-- of the name (excluding the suffix). Then, if the name
-- is still too long, it is truncated (again, excluding the ".xyz"
-- suffix, if any).
--
-- Finally, to produce a unique name (with respect to others going on to
-- the tape), 'A' characters are inserted in front of the suffix, if any,
-- (preserving the ".xyz" suffix) and then these characters are
-- incremented alphabetically until the name is unique.
-- Thus, "An_Interesting_Name_Txt" becomes (if not VAX/VMS bound),
-- "AnInterstngNm.Txt"
Error : exception;
procedure Examine_Labels (Vol_Id : String := "";
Vol_Set_Name : String := "";
To_Operator : String := "Thank you";
Volume_Labels_Only : Boolean := True);
procedure Format_Tape (Drive : Natural := 0; Vol_Id : String := "");
procedure Display_Tape (Drive : Natural := 0;
Marks_To_Skip : Integer := 0;
Records_To_Skip : Integer := 0;
Blocks_To_Display : Natural := 10);
pragma Subsystem (Input_Output);
pragma Module_Name (4, 3927);
end Tape;with System_Utilities;
with Telnet_Profile;
package Telnet is
subtype User_Name is String;
-- As used here, a User_Name is the name of a local user
-- and session, joined by a '.', for example "CAROL.S_1".
subtype Machine_Name is String;
-- The name of a remote machine, to be used by Transport_Name_Map.
subtype Session_Number is Positive;
-- A single user may have several Telnet sessions with one remote
-- machine: they are distinguished by different Session_Numbers.
procedure Connect (Remote_Machine : Machine_Name :=
Telnet_Profile.Remote_Machine;
Session : Session_Number := 1;
Escape : String := Telnet_Profile.Escape;
Escape_On_Break : Boolean :=
Telnet_Profile.Escape_On_Break;
Terminal : System_Utilities.Port :=
System_Utilities.Terminal);
-- Start or resume a session with the specified Remote_Machine
-- and Session number. If such a session already exists, it is
-- resumed, if not, a new session is started.
-- If Escape is non-null, and the Escape string is received
-- from the terminal, then the session will be suspended
-- and the terminal will be reconnected to the Environment.
-- If Escape_On_Break is true, then a BREAK signal from the
-- terminal will likewise escape from the session.
-- Terminal specifies the local terminal from which you want
-- to interact with the Remote_Machine. The default is the
-- same terminal you're currently logged in on.
function My_User_Name return User_Name;
procedure Disconnect (Remote_Machine : Machine_Name :=
Telnet_Profile.Remote_Machine;
Session : Session_Number := 1;
User : User_Name := Telnet.My_User_Name);
-- Disconnect the Telnet session with the specified Remote_Machine
-- and Session number which was started by the specified User.
-- If no such session exists, do nothing.
procedure Show_Sessions (User : User_Name := Telnet.My_User_Name);
-- Show a table of existing sessions for the specified User.
-- If User => "?", show existing sessions for all users.
procedure Send (Data : String := Telnet_Profile.Escape;
Remote_Machine : Machine_Name :=
Telnet_Profile.Remote_Machine;
Session : Session_Number := 1);
-- If a session to the specified Remote_Machine and Session
-- exists, send the specified Data on it. To the remote
-- machine, it looks as though the data came from the terminal.
-- If no such session exists, do nothing.
procedure Send_Break (Remote_Machine : Machine_Name :=
Telnet_Profile.Remote_Machine;
Session : Session_Number := 1);
-- If a session to the specified Remote_Machine and Session
-- exists, send a break signal on it. To the remote machine,
-- it looks as though the break signal came from the terminal.
-- If no such session exists, do nothing.
pragma Subsystem (Ftp_Interface, Private_Part => Closed);
pragma Module_Name (4, 3544);
end Telnet;with Default;
with Machine;
with System;
with System_Utilities;
package Terminal is
subtype Port is Natural range 0 .. 4 * 16 * 16;
-- valid terminal types
-- Rational, VT100, Facit
-- valid terminal rates
-- DISABLE, 50, 75, 110,
-- 134_5, 150, 200, 300,
-- 600, 1200, 1800, 2400,
-- 4800, 9600, 19200, EXT_REC_CLK
subtype Stop_Bits_Range is System_Utilities.Stop_Bits_Range;
subtype Character_Bits_Range is System_Utilities.Character_Bits_Range;
subtype Parity_Kind is System_Utilities.Parity_Kind;
-- None, Even, Odd
function Current (S : Machine.Session_Id := Default.Session) return Port
renames System_Utilities.Terminal;
procedure Settings (Line : Port := Terminal.Current);
-- print summary of current terminal
procedure Set_Terminal_Type
(Line : Port := Terminal.Current;
To_Be : String := System_Utilities.Terminal_Type);
procedure Set_Input_Rate (Line : Port := Terminal.Current;
To_Be : String := System_Utilities.Input_Rate);
procedure Set_Output_Rate (Line : Port := Terminal.Current;
To_Be : String := System_Utilities.Output_Rate);
procedure Set_Parity (Line : Port := Terminal.Current;
To_Be : Parity_Kind := System_Utilities.Parity);
procedure Set_Stop_Bits (Line : Port := Terminal.Current;
To_Be : Stop_Bits_Range :=
System_Utilities.Stop_Bits);
procedure Set_Character_Size (Line : Port := Terminal.Current;
To_Be : Character_Bits_Range :=
System_Utilities.Character_Size);
procedure Set_Xon_Xoff_Characters
(Line : Port := Terminal.Current;
Xon_Xoff : String := System_Utilities.Xon_Xoff_Characters);
-- takes a 2-element string consisting of Xon followed by Xoff
procedure Set_Xon_Xoff_Bytes (Line : Port := Terminal.Current;
Xon_Xoff : System.Byte_String :=
System_Utilities.Xon_Xoff_Bytes);
procedure Set_Flow_Control
(Line : Port := Terminal.Current;
To_Be : String := System_Utilities.Flow_Control);
procedure Set_Receive_Xon_Xoff_Characters
(Line : Port := Terminal.Current;
Xon_Xoff : String := System_Utilities.
Receive_Xon_Xoff_Characters);
procedure Set_Receive_Xon_Xoff_Bytes
(Line : Port := Terminal.Current;
Xon_Xoff : System.Byte_String :=
System_Utilities.Receive_Xon_Xoff_Bytes);
procedure Set_Receive_Flow_Control
(Line : Port := Terminal.Current;
To_Be : String := System_Utilities.Receive_Flow_Control);
procedure Set_Disconnect_On_Disconnect
(Line : Port := Terminal.Current;
Enabled : Boolean := System_Utilities.
Disconnect_On_Disconnect);
procedure Set_Logoff_On_Disconnect
(Line : Port := Terminal.Current;
Enabled : Boolean := System_Utilities.Logoff_On_Disconnect);
procedure Set_Disconnect_On_Logoff
(Line : Port := Terminal.Current;
Enabled : Boolean := System_Utilities.Disconnect_On_Logoff);
procedure Set_Disconnect_On_Failed_Login
(Line : Port := Terminal.Current;
Enabled : Boolean := System_Utilities.
Disconnect_On_Failed_Login);
procedure Set_Log_Failed_Logins
(Line : Port := Terminal.Current;
Enabled : Boolean := System_Utilities.Log_Failed_Logins);
procedure Set_Login_Disabled
(Line : Port := Terminal.Current;
Disabled : Boolean := System_Utilities.Login_Disabled);
procedure Set_Detach_On_Disconnect
(Line : Port := Terminal.Current;
Enabled : Boolean := System_Utilities.Detach_On_Disconnect);
pragma Subsystem (Os_Commands);
pragma Module_Name (4, 3925);
end Terminal;package Text is
type Image_Kind is (File, Input_Output);
procedure Create (Image_Name : String := ">>IMAGE_NAME<<";
Kind : Image_Kind := Text.File);
-- Create a text image.
-- Image_Kind = File a text file with the given name
-- Image_Kind = Input_Output creates an input_output image of that name
-- Commands run from an input_output image will have that image as the
-- default destination for Current_Output
procedure Block (All_Windows : Boolean := False);
procedure Continue (Page_Mode : Boolean := False;
All_Windows : Boolean := False);
procedure End_Of_Input;
procedure Redirect (To : String := ">>File Name<<");
-- Redirect the output associated with the current output
-- window to the named file.
pragma Subsystem (Command);
pragma Module_Name (4, 2210);
end Text;with Transport_Defs;
package Transport_Route is
-- The system maintains a table used for routing Transport
-- packets. At this time the routing table is used only
-- for IP packets, including TCP/IP and UDP/IP packets.
-- When sending a packet to a machine on some other network
-- (e.g. Ether), it must be routed first to a gateway, not the
-- destination machine. Some gateways do not respond to ARP
-- queries for destination machines whose traffic they carry,
-- so this machine must know the address of the gateway in
-- order to transmit packets to it.
-- The routing table contains a list of entries. Each entry
-- contains a route (i.e. the Internet address of a gateway)
-- with a destination that can be reached by way of it. The
-- destination may be a specific Host_Id (Internet address), or
-- the network number of a network (signifying all hosts in that
-- network), or the Null_Host_ID (signifying any remote host).
-- There may be multiple entries for each route, identifying
-- multiple hosts or networks accessible by way of that route.
-- The table entries are searched in order when deciding where
-- to send an outgoing packet. The table is kept ordered with
-- all host-specific entries followed by all network-specific
-- entries, followed by the default entry. Within each group,
-- entries are maintained in order they were defined.
procedure Show (Route : String := "";
Destination : String := "";
Network : Transport_Defs.Network_Name := "";
Response : String := "<PROFILE>");
-- Create a text listing of entries matching the given values,
-- and write it to the current output file. "" is a wildcard
-- for each parameter. That is, if Route = "", show entries
-- for all routes; if Destination = "", show entries for all
-- destinations; and if Network = "", show entries for all
-- networks. Route and/or Destination may be a Host_Id in
-- decimal dotted notation (e.g. "89.32") or a machine name
-- (e.g. "Fred"). In the latter case, the name is resolved
-- to a Host_Id using Transport_Name.Host_to_Host_Id.
procedure Load (Table : String := "!machine.transport_routes";
Form : String := "";
Response : String := "<PROFILE>");
-- Read the object named by Table, using package Text_Io.
-- Pass the specified Form to Text_Io.Open. In the resulting text,
-- each text line should contain the Host_ID or name of a route,
-- followed by the Host_ID or name of a destination, followed by
-- a Network_Name. If the Network_Name is omitted, "IP" is assumed.
-- If the destination Host_ID is omitted, the Null_Host_ID is assumed.
-- For each line in the Table, call the Define procedure (below)
-- with parameter values parsed from the line. The overall
-- effect is to copy the information from the object named by
-- Table into the system's routing table.
procedure Define (Route : String;
Destination : String := "";
Network : Transport_Defs.Network_Name := "IP";
Response : String := "<PROFILE>");
-- Add one entry to the routing table, with the given values.
-- If there is already such an entry in the table, do nothing.
-- Route and/or Destination can be a Host_Id, in decimal dotted
-- notation (e.g. "89.32"), or else a host name (e.g. "Fred").
-- If Route or Destination is a symbolic name, resolve it to
-- a Host_ID using Transport_Name.Host_to_Host_Id. If Route
-- or Destination = "", this means Transport_Defs.Null_Host_Id.
procedure Undefine (Route : String;
Destination : String := "";
Network : Transport_Defs.Network_Name := "IP";
Response : String := "<PROFILE>");
-- Delete the entry with the given values from the routing table.
-- If there is no such entry in the table, do nothing.
-- Route and/or Destination can be a Host_Id, in decimal dotted
-- notation (e.g. "89.32"), or else a host name (e.g. "Fred").
-- If Route or Destination is a symbolic name, resolve it to
-- a Host_ID using Transport_Name.Host_to_Host_Id. If Route
-- or Destination = "", this means Transport_Defs.Null_Host_Id.
pragma Subsystem (Input_Output);
pragma Module_Name (4, 3224);
end Transport_Route;package What is
procedure Does (Name : String := "");
procedure Command (Clue : String := "");
procedure Line;
procedure Tabs;
procedure Message (File : String := "Daily_Message");
procedure Time;
procedure Load (Verbose : Boolean := True);
procedure Version;
procedure Users (All_Users : Boolean := True);
procedure Jobs (Interval : Positive := 10;
User_Jobs_Only : Boolean := False;
My_Jobs_Only : Boolean := False;
Running_Jobs_Only : Boolean := True);
procedure Home_Library;
procedure Object (Name : String := "<IMAGE>");
procedure Locks (Name : String := "<IMAGE>");
procedure Search_List_Resolution (Name : String := "<CURSOR>");
-- Determines the object the given name will resolve to using the
-- current search list. The resolution and the search list entry that
-- provided the resolution are displayed in the message window.
pragma Subsystem (Command);
pragma Module_Name (4, 2217);
end What;package Work_Order is
procedure Set_Default_Venture (To_Venture : String := "<CURSOR>";
For_User : String := "<CURRENT_USER>";
Response : String := "<PROFILE>");
function Default_Venture (For_User : String := "<CURRENT_USER>";
Ignore_Garbage : Boolean := True) return String;
procedure Set_Notes_Venture (To_Value : String := ">>New Notes<<";
Venture_Name : String := "<VENTURE>";
Response : String := "<PROFILE>");
--
-- The "" Venture_Name is interpreted as "<CURSOR>".
-- "<VENTURE>" are interpreted as the default venture.
function Notes_Venture (Venture_Name : String := "<VENTURE>") return String;
--
-- The "" Venture_Name is interpreted as "<CURSOR>".
procedure Display_Venture (Venture_Name : String := "<VENTURE>";
Options : String := "";
Response : String := "<PROFILE>");
--
-- Display the object by formatting and printing it. The "" argument
-- is interpreted as "<CURSOR>"
-- Valid Options are all of the session switches, plus "<DEFAULT>"
-- (which is the current session switch values), "<TERSE>" (the default),
-- and "<VERBOSE>".
procedure Edit_Venture (Venture_Name : String := "<VENTURE>");
--
-- Invoke the appropriate object_editor. The "" Argument is
-- interpreted as "<CURSOR>"
procedure Create_Venture (Venture_Name : String := ">>OBJECT NAME<<";
Notes : String := "";
Make_Default_Venture : Boolean := True;
Response : String := "<PROFILE>");
--
-- Intended to be called from the command line
type Venture_Policy_Switch is (Require_Current_Work_Order,
Require_Comment_At_Check_In,
Require_Comment_Lines,
Journal_Comment_Lines,
Allow_Edit_Of_Work_Orders);
procedure Set_Venture_Policy (The_Switch : Venture_Policy_Switch;
To_Value : Boolean;
Venture_Name : String := "<VENTURE>";
Effort_Only : Boolean := False;
Response : String := "<PROFILE>");
--
-- Change a venture's policy switches.
-- The "" Venture_Name argument is interpreted as "<CURSOR>".
procedure Set_Default (To_Work_Order : String := "<CURSOR>";
For_Venture : String := "<VENTURE>";
For_User : String := "<CURRENT_USER>";
Response : String := "<PROFILE>");
function Default (For_Venture : String := "<VENTURE>";
For_User : String := "<CURRENT_USER>";
Ignore_Garbage : Boolean := True) return String;
procedure Set_Notes (To_Value : String := ">>New Notes<<";
Order_Name : String := "<ORDER>";
Response : String := "<PROFILE>");
--
-- The "" Order_Name argument is interpreted as "<CURSOR>".
function Notes (Order_Name : String := "<ORDER>") return String;
--
-- The "" Order_Name argument is interpreted as "<CURSOR>".
procedure Close (Order_Name : String := "<ORDER>";
Response : String := "<PROFILE>");
--
-- The "" Order_Name argument is interpreted as "<CURSOR>".
procedure Display (Order_Name : String := "<ORDER>";
Options : String := "";
Response : String := "<PROFILE>");
--
-- Display the object by formatting and printing it. The "" argument
-- is interpreted as "<CURSOR>".
-- Valid Options are all of the session switches, plus "<DEFAULT>"
-- (which is the current session switch values), "<TERSE>" (the default),
-- and "<VERBOSE>".
procedure Edit (Order_Name : String := "<ORDER>");
--
-- Invoke the appropriate object_editor. The "" Argument is
-- interpreted as "<CURSOR>"
procedure Create (Order_Name : String := ">>OBJECT NAME<<";
Notes : String := "";
On_List : String := "<WORK_LIST>";
On_Venture : String := "<VENTURE>";
Make_Default_Work_Order : Boolean := True;
Response : String := "<PROFILE>");
--
-- Command line interface
-- "" for list is interpreted as Nil (Added to no list)
procedure Create_Field (Field_Name : String := ">>FIELD NAME<<";
Field_Type : String := ">>BOOLEAN|STRING|INTEGER<<";
Is_Vector : Boolean := False;
Is_Controlled : Boolean := False;
Default : String := "";
Display_Position : Natural := Natural'Last;
On_Venture : String := "<VENTURE>";
Propagate : Boolean := True;
Renumber_Fields : Boolean := True;
Response : String := "<PROFILE>");
--
-- Create a new user-defined field in a Venture.
-- Field_Name is the name given to the field.
-- Field_Type can be "Boolean", "String", or "Integer".
-- If Is_Vector is true, the field is declared equivalent to
-- Field_Name : array (Positive) of Field_Type.
-- If Is_Controlled is true, whether or not the field is modifiable
-- using the object editor is controlled by a policy switch.
-- Display_Position specifies the relative position of this field
-- in the object editor display as compared to all of the other
-- user defined fields. 0 means don't display.
-- If Renumber_Fields is True, the display position is treated as
-- an ordinal number, i.e. a value of N will cause fields to be
-- renumbered so that the new one is the Nth in the sort order.
-- Default is the image of the default value (all elements of
-- a vector have the same default). If no default is supplied,
-- False, "", or 0 will be assumed.
-- If Propagate is True, all existing work orders will be updated.
procedure Delete_Field (Field_Name : String := ">>FIELD NAME<<";
Venture_Name : String := "<VENTURE>";
Even_If_Data_Present : Boolean := False;
Response : String := "<PROFILE>");
--
-- Delete the named field from the venture.
-- If work orders exist that have data in the field, the
-- operation fails unless Even_If_Data_Present is true.
procedure Add_To_List (Order_Names : String := "<IMAGE>";
List_Name : String := "<WORK_LIST>";
Response : String := "<PROFILE>");
procedure Remove_From_List (Order_Names : String := "<IMAGE>";
List_Name : String := "<WORK_LIST>";
Response : String := "<PROFILE>");
procedure Set_Default_List (To_List : String := "<CURSOR>";
For_Venture : String := "<VENTURE>";
For_User : String := "<CURRENT_USER>";
Response : String := "<PROFILE>");
function Default_List (For_Venture : String := "<VENTURE>";
For_User : String := "<CURRENT_USER>";
Ignore_Garbage : Boolean := True) return String;
procedure Set_Notes_List (To_Value : String := ">>New Notes<<";
List_Name : String := "<WORK_LIST>";
Response : String := "<PROFILE>");
--
-- The "" List_Name argument is interpreted as "<CURSOR>".
function Notes_List (List_Name : String := "<WORK_LIST>") return String;
--
-- The "" List_Name argument is interpreted as "<CURSOR>".
procedure Display_List (List_Name : String := "<WORK_LIST>";
Options : String := "";
Response : String := "<PROFILE>");
--
-- Display the object by formatting and printing it. The "" argument
-- is interpreted as "<CURSOR>".
-- "<WORK_LIST>" is the default list for the current user.
-- Valid Options are all of the session switches, plus "<DEFAULT>"
-- (which is the current session switch values), "<TERSE>" (the default),
-- and "<VERBOSE>".
procedure Edit_List (List_Name : String := "<WORK_LIST>");
--
-- Invoke the appropriate object_editor. The "" Argument is interpreted
-- as "<CURSOR>"
procedure Create_List (List_Name : String := ">>OBJECT NAME<<";
Notes : String := "";
On_Venture : String := "<VENTURE>";
Make_Default_List : Boolean := True;
Response : String := "<PROFILE>");
package Venture_Editor is
procedure Set_Notes (Notes : String := ">>New Notes<<");
procedure Set_Policy (To_Value : Boolean := False;
The_Switch : Venture_Policy_Switch);
procedure Spread_Fields (Interval : Natural := 10);
procedure Set_Field_Info (Is_Controlled : Boolean := False;
Display_Position : Natural := 1;
The_Field : String := ">>Field Name<<");
procedure Set_Default_Order (New_Default : String := "<SELECTION>";
For_User : String := "<CURRENT_USER>");
procedure Set_Default_List (New_Default : String := "<SELECTION>";
For_User : String := "<CURRENT_USER>");
--
-- Command line procedures for modifying a Venture.
end Venture_Editor;
package Editor is
procedure Set_Notes (Notes : String := ">>New Notes<<");
--
-- A command line procedure to change the Notes.
procedure Set_Field (To_Value : String := ">>Field Value<<";
The_Index : Natural := 0;
The_Field : String := ">>Field Name<<");
procedure Set_Field (To_Value : Integer := 0;
The_Index : Natural := 0;
The_Field : String := ">>Field Name<<");
procedure Set_Field (To_Value : Boolean := False;
The_Index : Natural := 0;
The_Field : String := ">>Field Name<<");
--
-- A command line procedure for changing a field in a Work_Order.
-- The_Index is ignored for scalar fields.
procedure Add_User (The_User : String := "<CURRENT_USER>");
procedure Add_Version (The_Configuration : String :=
">>Configuration Name<<";
The_Element : String := ">>Element Name<<";
The_Generation : Natural := 0);
procedure Add_Configuration
(The_Configuration : String := ">>Configuration Name<<");
procedure Add_Comment (The_Comment : String := ">>Comment<<";
The_Element : String := ">>Element Name<<";
The_User : String := "<CURRENT_USER>");
--
-- Command line procedures for augmenting a Work_Order.
end Editor;
package List_Editor is
procedure Set_Notes (Notes : String := ">>New Notes<<");
--
-- A command line procedure to change the Notes.
procedure Add (Work_Orders : String := ">>Work Order Names<<");
--
-- A command line procedure for adding to a Work_Order_List.
end List_Editor;
pragma Subsystem (Cmvc);
pragma Module_Name (4, 3781);
pragma Bias_Key (9);
end Work_Order;with Diana;
with System;
with Action;
with Directory;
package Diana_Expand is
pragma Subsystem (Compiler_Utilities, Private_Part => Closed);
pragma Module_Name (4, 2901);
subtype Heap_Type is System.Segment;
type Mapping is private;
-- mapping from formals to actuals and from nodes to brothers
procedure Expand_Inline_Subprogram (Subp_Id : Diana.Tree;
Formal_Id_List : Diana.Sequence;
Actuals_List : Diana.Sequence;
Actuals_Copy : out Diana.Seq_Type;
Block_Copy : out Diana.Tree;
Heap : Heap_Type);
-- expand an inlined subprogram body
function Copy (Node : Diana.Tree; Heap : Heap_Type) return Diana.Tree;
-- make semantically attributed copy of a tree
procedure Expand_Body (Instance_Id : Diana.Tree;
Instantiation : Diana.Tree;
Unit_Body : out Diana.Tree;
Heap : Heap_Type;
Action_Id : Action.Id);
-- expand a body (if any) of a generic whose visible part has been
-- previously expanded
-- the following procedures are used by the semantics while
-- checking a generic instantiation.
-- START_ACTUAL_MAPPINGS must be called first.
-- followed by calls to add mappings.
-- then a call to expand the instantiation.
procedure Start_Actual_Mappings (Map : in out Mapping; Heap : Heap_Type);
-- setup for the mappings from formals to actuals
procedure Add_Actual_Mapping (Formal_Id : Diana.Tree;
Actual : Diana.Tree;
Map : in out Mapping);
-- add a mapping from a formal id to its corresponding actual
procedure New_Actual_Mapping (Formal_Id : Diana.Tree;
Actual : Diana.Tree;
Map : in out Mapping;
Result : out Diana.Tree);
-- add a mapping from a formal id to its corresponding actual and return
-- the tree for the declaration constructed
procedure Context_Dependent_Copy (Node : Diana.Tree;
Copy : out Diana.Tree;
Map : in out Mapping);
-- copy a node relative to formal/actual mappings
procedure Expand_Instantiation (Unit_Id : Diana.Tree;
Instantiation : Diana.Tree;
Append_Trees : out Diana.Sequence;
Map : in out Mapping;
Expand_Body : Boolean := True;
Action_Id : Action.Id);
-- expand an instantiation based on formal/actual mappings
end Diana_Expand;with Action;
with Diana;
package Indirect_Attributes is
-- This package implements extended versions of certain
-- semantic attributes. In standard Diana these attributes
-- are defined to be Void in cases which would involve forward
-- references across separate units. The versions here
-- use information in the package directory system and will
-- return a non-Void value if it is possible to compute one.
-- This means, for example, that the version of sm_body here will
-- return Void only if there is no installed body. A separate,
-- installed body would be found and returned, where the sm_body
-- in Diana would return void in that case.
function Sm_Type_Spec (T : Diana.Tree;
Max_Wait : Duration := Duration'Last;
Action_Id : Action.Id) return Diana.Tree;
function Sm_Body (T : Diana.Tree;
Max_Wait : Duration := Duration'Last;
Action_Id : Action.Id) return Diana.Tree;
function Sm_Stub (T : Diana.Tree;
Max_Wait : Duration := Duration'Last;
Action_Id : Action.Id) return Diana.Tree;
function Sm_Spec (T : Diana.Tree;
Max_Wait : Duration := Duration'Last;
Action_Id : Action.Id) return Diana.Tree;
function Sm_Generic_Param_S (T : Diana.Tree;
Max_Wait : Duration := Duration'Last;
Action_Id : Action.Id) return Diana.Tree;
function Get_Body (T : Diana.Tree;
Max_Wait : Duration := Duration'Last;
Action_Id : Action.Id := Action.Null_Id)
return Diana.Tree;
-- same as sm_body but for T's in the visible part of an expanded
-- instantiation spec it will try to find the body in the body of
-- the generic being instantiated.
-- for an instantiation id it will return the generic body.
function Get_Type_Spec
(T : Diana.Tree;
Max_Wait : Duration := Duration'Last;
Action_Id : Action.Id := Action.Null_Id) return Diana.Tree;
generic
with function Resolve (Node : Diana.Tree) return Diana.Tree;
-- mapping for subsystem spec look-through
function Get_Body_Generic
(T : Diana.Tree;
Max_Wait : Duration := Duration'Last;
Action_Id : Action.Id := Action.Null_Id) return Diana.Tree;
generic
with function Resolve (Node : Diana.Tree) return Diana.Tree;
-- mapping for subsystem spec look-through
function Get_Type_Spec_Generic
(T : Diana.Tree;
Max_Wait : Duration := Duration'Last;
Action_Id : Action.Id := Action.Null_Id) return Diana.Tree;
function Corresponding_Def_Id_In_Generic
(Def_Id : Diana.Tree) return Diana.Tree;
-- given a def_id for a decl in the visible part of an expanded generic
-- spec, find the corresponding def_id in the actual generic spec,
-- looking thru levels of nested generic instantiations.
pragma Subsystem (Directory);
pragma Module_Name (4, 1707);
end Indirect_Attributes;with System;
with Machine;
with Action;
with Diana;
with Error_Messages;
with Directory;
with Switch_Implementation;
with Units_In_Program;
package R1000_Code_Generator is
package Switch renames Switch_Implementation;
pragma Consume_Offset;
package Switches is
procedure Set_Global_Tracing (On : Boolean := True);
-- each form of Set may raise switch.undefined_switch_name
procedure Set (Switches : in out Switch.File;
Switch : String;
Value : Boolean;
Action_Id : Action.Id := Action.Null_Id);
procedure Set (Switches : in out Switch.File;
Switch : String;
Value : Integer;
Action_Id : Action.Id := Action.Null_Id);
procedure Set (Switches : in out Switch.File;
Switch : String;
Value : String;
Action_Id : Action.Id := Action.Null_Id);
procedure Cmd_Set (Switch : String; Value : Boolean);
procedure Cmd_Set (Switch : String; Value : Integer);
procedure Cmd_Set (Switch : String; Value : String);
end Switches;
-- the following generic should be instantiated with the same
-- put and new_line procedures used to instantiate diana.symbolic_io;
-- the result is passed to symbolic_io as print_other_attrs.
generic
with procedure Put (S : String);
with procedure New_Line;
package Attr_Display is
procedure Print_Cg_Attrs (Node : Diana.Tree; Indent : Integer);
end Attr_Display;
package Exported_Attrs is
-- FILE ATTRIBUTES
function Has_Code_Segment (T : Diana.Tree) return Boolean;
function Get_Code_Segment (T : Diana.Tree) return Directory.Object;
function Has_List_File (T : Diana.Tree) return Boolean;
function Get_List_File (T : Diana.Tree) return Directory.Object;
function Has_Asm_File (T : Diana.Tree) return Boolean;
function Get_Asm_File (T : Diana.Tree) return Directory.Object;
function Has_Debug_List_File (T : Diana.Tree) return Boolean;
function Get_Debug_List_File (T : Diana.Tree) return Directory.Object;
function Has_Elab_Code_Segment (T : Diana.Tree) return Boolean;
function Get_Elab_Code_Segment (T : Diana.Tree) return Directory.Object;
function Has_Elab_List_File (T : Diana.Tree) return Boolean;
function Get_Elab_List_File (T : Diana.Tree) return Directory.Object;
function Has_Elab_Asm_File (T : Diana.Tree) return Boolean;
function Get_Elab_Asm_File (T : Diana.Tree) return Directory.Object;
-- CG_LEVEL
-- The control stack lexical level for an object
-- Attached to all id nodes which correspond to runtime objects
function Get_Level (Node : Diana.Tree) return Integer;
-- CG_OFFSET
-- The control stack offset of a variable
-- or the field index of a record field
-- Attached to all id nodes which correspond to runtime objects or
-- are record fields
function Get_Offset (Node : Diana.Tree) return Integer;
function Has_Offset (Node : Diana.Tree) return Boolean;
-- CG_INT_VALUE
-- simplified value of expression for debugger
-- can be attached to any expression
function Has_Int_Value (Node : Diana.Tree) return Boolean;
function Get_Int_Value (Node : Diana.Tree) return Integer;
-- CG_VARIABLE_SIZE_FIELD
-- True if the field type has a dependent discriminant constraint
-- Attached to field_ids
function Is_Variable_Size (Defn : Diana.Tree) return Boolean;
-- CG_VARIANT_FIELD
-- True if the field is a variant field
-- Attached to field_ids
function Is_Variant_Field (Defn : Diana.Tree) return Boolean;
-- CG_STMT_NUMBER
-- Attached to all dn_accept nodes and dn_block nodes which represent
-- block statements.
-- Gives the source statement number of the accept or block.
function Has_Stmt_Number (Node : Diana.Tree) return Boolean;
function Get_Stmt_Number (Node : Diana.Tree) return Integer;
-- RCG_MAJOR_VERSION
-- RCG_MINOR_VERSION
-- attached to comp_unit
-- indicates version of Rcg that was last used on this unit
function Has_Rcg_Major_Version (Node : Diana.Tree) return Boolean;
function Get_Rcg_Major_Version (Node : Diana.Tree) return Integer;
function Has_Rcg_Minor_Version (Node : Diana.Tree) return Boolean;
function Get_Rcg_Minor_Version (Node : Diana.Tree) return Integer;
-- CG_COUPLER_SUBPROGRAM
-- indicates whether subprogram is special coupler subprogram
function Is_Coupler_Subprogram (Node : Diana.Tree) return Boolean;
-- CG_UNITS_IN_PROGRAM
function Get_Units_In_Program (Main_Unit_Id : Diana.Tree)
return Units_In_Program.Library_Unit_List;
function Has_Units_In_Program
(Main_Unit_Id : Diana.Tree) return Boolean;
-- CG_ELAB_SEG_NUMBER
function Has_Elab_Seg_Number (Main_Unit_Id : Diana.Tree) return Boolean;
function Get_Elab_Seg_Number (Main_Unit_Id : Diana.Tree) return Integer;
-- CG_SEG_NUMBER
function Has_Seg_Number (Unit_Id : Diana.Tree) return Boolean;
function Get_Seg_Number (Unit_Id : Diana.Tree) return Integer;
function Is_Inline_Frame (Frame : Diana.Tree) return Boolean;
-- Kind (Frame) is: dn_block (a block statement)
-- dn_proc_id, dn_function_id, dn_def_op
-- (as_designator of first id of subprogram)
function Is_Integrated_Package (Package_Id : Diana.Tree) return Boolean;
-- Kind (Package_id) is dn_package_id (the cg_first id).
end Exported_Attrs;
pragma Subsystem (R1000_Code_Gen);
pragma Module_Name (4, 1601);
end R1000_Code_Generator;with Diana;
package Simplifier is
pragma Subsystem (Compiler_Utilities);
pragma Module_Name (4, 2902);
procedure Simplify (T : Diana.Tree;
Static : out Boolean;
Value : out Diana.Value);
procedure Simplify (T : Diana.Tree;
Static : out Boolean;
Lo, Hi : out Diana.Value);
function Get_Value (T : Diana.Tree) return Diana.Value;
end Simplifier;with Diana;
with Directory;
package Units_In_Program is
pragma Subsystem (Compiler_Utilities);
pragma Module_Name (4, 3527);
-- Utilities for interrogating the library units
-- associated with a loaded program or subsystem.
type Library_Unit_List is private;
-- A Library_Unit_List is a list of all library units that were loaded
-- together to form the program of interest. Each library unit has a
-- a unique index. Ordering of index values is not signficant.
-- Each library unit has associated with it a name, a kind, a diana
-- pointer to the actual diana tree, and a set of spec units that
-- were "looked-through" to get to the unit in the program.
-- The Spec units for a given library unit are identified by a unique
-- index. Ordering of index values has no significance.
Null_Library_Unit_List : constant Library_Unit_List;
type Library_Unit_Index is new Natural;
type Spec_Unit_Index is new Natural;
pragma Consume_Offset (3);
-- Set the spec info for a specific library unit.
function Get_Library_Unit_Count
(Units : Library_Unit_List) return Library_Unit_Index;
-- Get the number of library units in the list.
procedure Get_Library_Unit_Info (Units : Library_Unit_List;
Unit : Library_Unit_Index;
Unit_Name : out Diana.Symbol_Rep;
Unit_Kind : out Diana.Node_Name;
Unit_Defn : out Diana.Tree;
Unit_Offset : out Natural;
Unit_Is_Main : out Boolean;
Unit_Is_Archived : out Boolean;
Archive_Object : out Directory.Version;
Spec_Unit_Count : out Spec_Unit_Index);
-- Get information for a specific library unit.
procedure Get_Spec_Info (Units : Library_Unit_List;
Unit : Library_Unit_Index;
Spec : Spec_Unit_Index;
Spec_Defn : out Diana.Tree);
-- Get information for a specific spec.
private
type Library_Unit_Table;
type Library_Unit_List is access Library_Unit_Table;
pragma Segmented_Heap (Library_Unit_List);
Null_Library_Unit_List : constant Library_Unit_List := null;
end Units_In_Program;with Low_Level_Action;
with Machine;
package Action is
package Lla renames Low_Level_Action;
subtype Id is Lla.Id;
Null_Id : constant Id := Lla.Null_Id;
function "=" (A, B : Id) return Boolean renames Lla."=";
function Hash (The_Action : Id) return Integer renames Lla.Hash;
subtype Mode is Lla.Mode;
None : constant Mode := Lla.None;
Read : constant Mode := Lla.Read;
Update : constant Mode := Lla.Update;
Overwrite : constant Mode := Lla.Overwrite;
function "=" (A, B : Mode) return Boolean renames Lla."=";
pragma Consume_Offset;
function Is_In_Progress (Of_Action : Id) return Boolean
renames Lla.Is_In_Progress;
-- methods of starting an action
-- action_parameter = null_id (if present) ==> returns a new action
-- mode parameter(s) = none (if present) ==> returns Bogus action
pragma Consume_Offset;
function Start (Task_Id : Machine.Task_Id := Machine.Get_Task_Id) return Id
renames Lla.Get_Id;
function Start (Action_Parameter : Action.Id;
Task_Id : Machine.Task_Id := Machine.Get_Task_Id) return Id;
function Start (Action_Parameter : Id;
Access_Mode : Mode;
Task_Id : Machine.Task_Id := Machine.Get_Task_Id) return Id;
function Start (Action_Parameter : Id;
Access_Mode_1 : Mode;
Access_Mode_2 : Mode;
Task_Id : Machine.Task_Id := Machine.Get_Task_Id) return Id;
-- methods of finishing an action
-- do_commit controls whether the action is committed or abandoned
-- do_inform controls whether object managers are automatically informed
-- the second form finishes if and only if Action_Parameter /= Null_Id
procedure Finish (The_Action : in out Action.Id;
Do_Commit : Boolean;
Do_Inform : Boolean := True);
procedure Finish (Action_Parameter : Action.Id;
Action_Local : in out Action.Id;
Do_Commit : Boolean;
Do_Inform : Boolean := True);
procedure Prevent_Commit (The_Action : Id) renames Lla.Prevent_Commit;
Commit_Prevented : exception renames Lla.Commit_Prevented;
pragma Subsystem (Om_Mechanisms);
pragma Module_Name (4, 902);
end Action;with Action;
with Directory;
package Activity_Implementation is
-- An Activity maps a subsystem to a spec view and a non-spec view of
-- that subsystem.
pragma Subsystem (Directory, Closed);
pragma Module_Name (4, 2909);
subtype Activity_Id is Directory.Object;
subtype Subsystem_Id is Directory.Object;
subtype Spec_View_Id is Directory.Object;
subtype Load_View_Id is Directory.Object;
function Null_Activity return Activity_Id renames Directory.Nil;
function Null_Subsystem return Subsystem_Id renames Directory.Nil;
function Null_Spec_View return Spec_View_Id renames Directory.Nil;
function Null_Load_View return Load_View_Id renames Directory.Nil;
type Activity_Handle is limited private;
function Current return Activity_Id;
-- returns Activity currently associated with this job; if no Activity
-- has been associated with this job, then returns Activity currently
-- associated with this sesssion.
procedure Set (Activity : Activity_Id);
-- make Activity the current activity for this job only
procedure Set_Default (Activity : Activity_Id);
-- make Activity the current activity for this job and session
function Nil return Activity_Handle;
function Is_Nil (Handle : Activity_Handle) return Boolean;
procedure Open (Activity : Activity_Id;
Handle : in out Activity_Handle;
Status : out Directory.Error_Status;
Action_Id : Action.Id := Action.Null_Id;
For_Update : Boolean := False;
Prevent_Create : Boolean := False);
procedure Close (Handle : in out Activity_Handle;
Status : out Directory.Error_Status);
--
-- An open/close protocol is used to deal with the problem of concurrent
-- access to activities. A new version of the activity will be created
-- when an Activity_Id is opened For_Update unless Prevent_Create is
-- set to True
pragma Consume_Offset (1);
function Enclosing_View (Unit : Directory.Ada.Unit) return Directory.Object;
--
-- returns either a Spec_View_Id or a Load_View_Id.
function Enclosing_Subsystem
(View_Id : Directory.Object) return Subsystem_Id;
--
-- takes either a Spec_View_Id or a Load_View_Id
procedure Create (New_Activity : String;
Action_Id : Action.Id;
Status : out Directory.Error_Status;
New_Id : out Activity_Id);
type Creation_Mode is (Differential, Exact_Copy, Value_Copy);
procedure Create (New_Activity : String;
From : Activity_Handle;
Status : out Directory.Error_Status;
New_Id : out Activity_Id;
Mode : Creation_Mode := Exact_Copy);
--
-- Create New_Activity based on the contents of From (and using Action_Id
-- associated with From)
procedure Add_Subsystem (Subsystem : Subsystem_Id;
Load_View : Load_View_Id := Null_Load_View;
Spec_View : Spec_View_Id := Null_Spec_View;
Handle : Activity_Handle);
-- Add a subsystem to the domain of an activity. If both a load view
-- and a spec view are specified they must both have the same target
-- key.
procedure Remove_Subsystem
(Subsystem : Subsystem_Id; Handle : Activity_Handle);
-- Remove a subsystem from the domain of an activity. This version of
-- Remove_Subsystem removes all entries for the specified subsystem
-- regardless of target key.
function Has_Subsystem (Subsystem : Subsystem_Id; Handle : Activity_Handle)
return Boolean;
-- Test subsystem's membership in domain of an activity. This version
-- tests for the existence of any entry for the subsystem independent of
-- target key.
function Get_Spec_View (Subsystem : Subsystem_Id; Handle : Activity_Handle)
return Spec_View_Id;
function Get_Load_View (Subsystem : Subsystem_Id; Handle : Activity_Handle)
return Load_View_Id;
procedure Set_Spec_View (Spec_View : Spec_View_Id;
Handle : Activity_Handle);
procedure Set_Load_View (Load_View : Load_View_Id;
Handle : Activity_Handle);
function Get_Spec_View_Source (Subsystem : Subsystem_Id;
Handle : Activity_Handle) return Activity_Id;
function Get_Load_View_Source (Subsystem : Subsystem_Id;
Handle : Activity_Handle) return Activity_Id;
procedure Set_Spec_View_Source (Subsystem : Subsystem_Id;
Source : Activity_Id;
Handle : Activity_Handle);
procedure Set_Load_View_Source (Subsystem : Subsystem_Id;
Source : Activity_Id;
Handle : Activity_Handle);
procedure Get_Spec_Value (Subsystem : Subsystem_Id;
Indirect : out Boolean;
Value : out Directory.Object;
Handle : Activity_Handle);
procedure Get_Load_Value (Subsystem : Subsystem_Id;
Indirect : out Boolean;
Value : out Directory.Object;
Handle : Activity_Handle);
procedure Get_Values (Subsystem : Subsystem_Id;
Spec_Indirect : out Boolean;
Spec_Value : out Directory.Object;
Load_Indirect : out Boolean;
Load_Value : out Directory.Object;
Handle : Activity_Handle);
procedure Set_Spec_Value (Subsystem : Subsystem_Id;
Indirect : Boolean;
Value : Directory.Object;
Handle : Activity_Handle);
procedure Set_Load_Value (Subsystem : Subsystem_Id;
Indirect : Boolean;
Value : Directory.Object;
Handle : Activity_Handle);
procedure Set_Values (Subsystem : Subsystem_Id;
Spec_Indirect : Boolean;
Spec_Value : Directory.Object;
Load_Indirect : Boolean;
Load_Value : Directory.Object;
Handle : Activity_Handle);
Undefined : exception;
type Handle_Ref is access Activity_Handle;
pragma Segmented_Heap (Handle_Ref);
type Iterator is limited private;
procedure Init (Iter : out Iterator; Handle : Handle_Ref);
procedure Next (Iter : in out Iterator);
function Done (Iter : Iterator) return Boolean;
function Get_Subsystem (Iter : Iterator) return Subsystem_Id;
function Is_Activity (File : Directory.Object) return Boolean;
pragma Consume_Offset (3);
function Is_Valid (Value : Directory.Object;
Activity : Activity_Id;
As_View : Boolean := False;
As_Spec : Boolean := False) return Boolean;
-- Verifies that the given value satisfies all consistency conditions
-- imposed on entries within the given activity.
function Diagnose (Value : Directory.Object;
Activity : Activity_Id;
As_View : Boolean := False;
As_Spec : Boolean := False) return String;
-- Verifies that the given value satisfies all consistency conditions
-- imposed on entries within the given activity and composes a
-- reason why it is invalid. Returns the null string if it is valid.
function Get_Activity_Id (Handle : Activity_Handle) return Activity_Id;
function Get_Activity_Id (Iter : Iterator) return Activity_Id;
-- Retrieve Activity id from open Handle or Iterator
end Activity_Implementation;with Action;
with Calendar;
with Cmvc_Implementation_Errors;
with Directory;
with Io;
package Cmvc_Implementation is
pragma Subsystem (Tools);
pragma Module_Name (4, 3760);
-- CMVC is based on the notion of elements. An element is a logical
-- entity that encapsulates changes within objects over time. Any
-- object class that has a text representation and conversion functions
-- can be managed by CMVC. Elements have an internal name, supplied
-- when the element is created. This is the name used for all CMVC
-- operations. There is an external name associated with each version
-- set, which is used for all copy in and out operations.
-- Each version of an element is a snapshot of that element. It
-- represents a physical realization of that element at some point in
-- its history. A Gamma version has this property. Each successive
-- version is a new generation of the element.
-- A view is defined to mean a snapshot of a collection of elements; it
-- calls out specific versions of specific elements. This isn't
-- necessarily a physical representation. In other words, this isn't a
-- world but a more abstract concept.
-- A version set is a time ordered set of versions for one element.
-- There is a straight line of descent; each version was created from
-- its parent by changing the parent. There is no skipping; every
-- generation of the element is represented. Each version set for an
-- element represents a different time line, and each can be reserved
-- independently. Only one version in a version set can be checked
-- out, and this is the newest version. The version set is optionally
-- named, which is useful for iterating over the sets. The version set
-- also maintains the external name for this set of versions of the
-- element.
-- A configuration is a realization of a view. A configuration can have
-- a directory name, which means there is some representation on the
-- disk for it. There are two types of configurations, release
-- configurations and working configurations. A working configuration
-- is one in which versions can be changed. A release configuration
-- specifies a set of versions which are frozen; neither the release
-- configuration nor the versions specified can be changed.
-- Configurations are named by the user.
-- In many cases software must run on various targets. It is often the
-- case that most of the elements are the same, but a few may be
-- different to account for the differences in the targets. It is
-- desirable to capture this information in order to allow simultaneous
-- independent changes to the elements that are different, while
-- controlling access to the elements that are the same. Another
-- common scenario is the need to have two people work on one element
-- in parallel for some time, then merge the changes together. The
-- process of splitting elements and operating on them is called
-- maintaining varying lines of descent. These variants branch out from
-- some line, and may rejoin later. Branching out is done using create;
-- bringing two alternate lines together is done using merge. In CMVC,
-- alternate lines of descent is accomplished by using version sets and
-- configurations. Each version set is a line of descent for some
-- element. Each configuration selects at most one version set for an
-- element. Configurations that refer to the same version set are
-- linked; the element has one reservation across all such
-- configurations, and can only be changed serially. If the
-- configurations refer to different version sets for an element, the
-- element can be reserved independently.
-- There is a database for each set of related configurations. The
-- database must be provided to each operation discussed below.
No_Such_Generation : exception;
No_Such_Version_Set : exception;
No_Such_Element : exception;
Bogus_Parameters : exception;
Unknown_Error : exception;
-- The above are the only exceptions propagated out of this package.
-- Unknown_error is raised for internal errors and unexpected errors
-- propagated out of other packages. Bogus_Parameters is raised when
-- the parameters make no sense, such as when configurations from one
-- database are mixed with elements from another.
subtype Library_Name is String;
subtype History_File is String;
subtype Error_Status is Cmvc_Implementation_Errors.Status;
subtype Error_Msg is String;
function Is_Bad (Status : Error_Status) return Boolean
renames Cmvc_Implementation_Errors.Is_Bad;
function Error_Msg_Of (Status : Error_Status) return Error_Msg;
---------------------------------
-- Note: values of the following types can be reliably compared for
-- equality using "=" only if there is one database handle being used
-- in some job for one database. If this can't be guaranteed, the
-- name should be extracted and compared. If it is possible that
-- different databases are in use, then the database name should also be
-- extracted and compared.
-- There is a database for each set of related configurations.
type Database is private;
function Nil return Database;
function Is_Nil (Db : Database) return Boolean;
type Configuration is private;
function Nil return Configuration;
function Is_Nil (Config : Configuration) return Boolean;
type Element is private;
function Nil return Element;
function Is_Nil (Elem : Element) return Boolean;
type Element_Class is
record
Class : Directory.Class;
Subclass : Directory.Subclass;
end record;
type Version_Set is private;
function Nil return Version_Set;
function Is_Nil (Set : Version_Set) return Boolean;
subtype Generation is Natural;
function Nil return Generation;
function Last_Version return Generation;
-- Last_Version returns a value that stands in for whatever the newest
-- generation in the version set is. It is not the actual generation
-- of the newest version
package Database_Operations is
function Name_Of (Db : Database) return String;
procedure Open (Db_Name : String;
Action_Id : Action.Id;
Db : out Database;
Status : out Error_Status);
procedure Open (Db_Object : Directory.Object;
Action_Id : Action.Id;
Db : out Database;
Status : out Error_Status);
procedure Create (Db_Name : String;
Action_Id : Action.Id;
Db : out Database;
Status : out Error_Status;
Dont_Keep_Source : Boolean := False);
procedure Close (Db : Database;
Status : out Error_Status;
Prevent_Commit : Boolean := False);
-- If dont_keep_source is true, no source differentials are kept in
-- the database. This means versions cannot be retrieved from the
-- database, and that the merge command depends on external objects
-- versus internal information. It is set to true to save disk
-- space and to speed up check in.
procedure Expunge (Db : Database; Status : out Error_Status);
-- Removes all elements and version sets not referenced by a
-- configuration.
end Database_Operations;
package Configuration_Operations is
function Name_Of (Config : Configuration) return String;
function Database_Of (Config : Configuration) return Database;
subtype Configuration_Object is Directory.Object;
function Is_Configuration_Object
(Obj : Configuration_Object; Action_Id : Action.Id)
return Boolean;
procedure Open (Config_Name : String;
Config : out Configuration;
Status : out Error_Status;
Db : Database);
procedure Open (Obj : Configuration_Object;
Action_Id : Action.Id;
Db : in out Database;
Config : out Configuration;
Status : out Error_Status);
-- Return a handle to a configuration. The configuration must exist.
-- This handle is used for most interesting element operations.
procedure Create (Config_Name : String;
Config : out Configuration;
Status : out Error_Status;
Golden_Config : Configuration := Nil;
Default_Library : String := "";
Version_Set_Name : String := "";
Initial : Configuration := Nil;
Make_Copies : Boolean := False;
Is_Release : Boolean := False;
Db : Database);
-- Create a new configuration. It can optionally be initialized.
-- If make_copies is true, new version_sets are made in each of the
-- elements selected by the initial configuration, which are then
-- initialized with the version selected by the initial
-- configuration. These version sets are given the name provided.
-- If no name is provided, the version sets are given the
-- configuration name.
-- If make_copies is false, the new configuration
-- references all the same version sets and versions as the initial
-- configuration, and the version_set_name parameter is ignored. In
-- other words, it is linked. If is_release is true, the new
-- configuration is frozen (is a release).
-- Golden_Config is the name of a configuration that is to be
-- copied into automatically whenever an element is checked in.
-- The intent is to allow the user to keep a current copy of
-- everything. This package doesn't actually do the copying, but
-- makes available the information to the command packages.
-- Default_Library is the name of the library to be used by default
-- for this configuration. It is used in all commands that require
-- a library, but are given the null string.
function Golden_Config_Of (Config : Configuration) return Configuration;
function Default_Library_Of (Config : Configuration) return String;
procedure Create_Config_Object (Name : String;
Config : Configuration;
Status : out Error_Status);
-- Create a configuration object with name 'name'. This object can be
-- used to get a configuration handle. If a configuration object
-- editor is ever provided, it would accept one of these.
procedure Delete (Config : Configuration;
Status : out Error_Status;
Delete_Release : Boolean := False);
-- Delete a configuration. The elements and version sets are not
-- deleted. Delete_release must be true to delete a release
-- configuration.
function Is_Release (Config : Configuration) return Boolean;
-- Returns true if the argument is a release configuration.
end Configuration_Operations;
package Element_Operations is
function Name_Of (Elem : Element) return String;
procedure Open (Element_Name : String;
Elem : out Element;
Status : out Error_Status;
Db : Database);
-- Gets a handle for an element. This handle is used to look at the
-- various version sets for the element.
procedure Create (Element_Name : String;
Config : Configuration;
Class : Element_Class;
External_Name : String;
Elem : out Element;
Status : out Error_Status;
Initial_Value_Set : Version_Set := Nil;
Initial_Value : Generation := Nil;
Version_Set_Name : String := "";
Dont_Keep_Source : Boolean := False);
procedure Create (Element_Name : String;
Db : Database;
Class : Element_Class;
External_Name : String;
Version_Set_Name : String;
Elem : out Element;
Status : out Error_Status;
Initial_Value_Set : Version_Set := Nil;
Initial_Value : Generation := Nil;
Dont_Keep_Source : Boolean := False);
procedure Create (Element_Name : String;
Config : Configuration;
Class : Element_Class;
External_Name : String;
Elem : out Element;
Status : out Error_Status;
Initial_Value_Object :
Directory.Object := Directory.Nil;
Version_Set_Name : String := "";
Dont_Keep_Source : Boolean := False);
procedure Create
(Element_Name : String;
Db : Database;
Class : Element_Class;
External_Name : String;
Version_Set_Name : String;
Elem : out Element;
Status : out Error_Status;
Initial_Value_Object : Directory.Object := Directory.Nil;
Dont_Keep_Source : Boolean := False);
-- Create a new element. The new element can be inserted into a
-- configuration (using the first procedure). An empty version set is
-- created for the element. In the case that a configuration is
-- supplied, the version set name defaults to the configuration name.
-- In the database case, the version set name must be supplied. The
-- version set is optionally initialized by copying the contents of a
-- version into it (as generation 1). The configuration must be a
-- working configuration. Path_from_library specifies a string that is
-- to be prepended to the element name and appended to the library name
-- when the element is copied out of the database. Initial_value_object
-- is the name of some directory object that is to be used as an
-- initial value.
procedure Delete (Elem : Element;
Config : Configuration;
Status : out Error_Status);
-- Delete the element from the configuration. The element is not
-- deleted from the database. The configuration must be a working
-- configuration.
procedure Delete (Elem : Element; Status : out Error_Status);
-- Delete the element from all working configurations in the database.
-- This operation ignores release configurations.
procedure Add (Elem : Element;
Status : out Error_Status;
Config : Configuration);
-- This operation adds an element (and a version set) to a working
-- configuration. There must be only one version set associated with
-- the element to use this operation.
function Is_In_Configuration
(Elem : Element; Config : Configuration) return Boolean;
-- Returns true if some version set of the element is referenced by the
-- configuration
function Class_Of (Elem : Element) return Element_Class;
-- return the class data for an element
function Saves_Source (Elem : Element) return Boolean;
-- Is source saved for this element?
end Element_Operations;
---------------------------------
package Version_Set_Operations is
function Name_Of (Set : Version_Set) return String;
procedure Open (Set_Name : String;
Elem : Element;
Set : out Version_Set;
Status : out Error_Status);
-- Get a handle on a version set. This handle is used to traverse
-- across the versions contained in the set.
procedure Open (Elem : Element;
Set : out Version_Set;
Status : out Error_Status;
Config : Configuration);
-- Get a handle on a version set determined by an element/configuration
-- pair.
procedure Create (Set_Name : String;
Elem : Element;
External_Name : String;
Set : out Version_Set;
Status : out Error_Status;
Initial_Value_Set : Version_Set := Nil;
Initial_Value : Generation := Nil);
procedure Create
(Set_Name : String;
Elem : Element;
External_Name : String;
Set : out Version_Set;
Status : out Error_Status;
Initial_Value_Object : Directory.Object := Directory.Nil);
-- Create a new version set in some element. The new version set can
-- be initialized.
procedure Add (Set : Version_Set;
Config : Configuration;
Status : out Error_Status;
Gen : Generation := Last_Version;
Replace_Ok : Boolean := True);
-- Add (or replace) a version set to a configuration. This operation
-- implies the adding of an element as well, as a version set is
-- contained within an element. The configuration must be a working
-- one. The configuration is set to refer to the specified version
procedure Prune (Set : Version_Set;
Up_To_Generation : Generation;
Status : out Error_Status);
-- Throw away the first up to the up_to_generation versions from the
-- version set. This operation fails if any configuration references a
-- version to be discarded. An iterator exists to help find these
-- blocking configuration(s).
procedure Change_External_Name (Set : Version_Set;
External_Name : String;
Status : out Error_Status);
-- Modify the name used for the version set. This name is appended to the
-- library name to build a complete external name.
-- Note that this affects all configurations using the version set.
function External_Name_Of (Set : Version_Set) return String;
-- Return the path specified when the version set was made.
function Element_Of (Set : Version_Set) return Element;
end Version_Set_Operations;
---------------------------------
package Generation_Operations is
function Generation_Of
(Elem : Element; Config : Configuration) return Generation;
function Generation_Of (Set : Version_Set; Config : Configuration)
return Generation;
-- Get the generation selected by a configuration.
function First_Generation_Of (Set : Version_Set) return Generation;
-- Return the generation of the first version for the set. This is
-- something other than one after a prune_version_set
function Last_Generation_Of (Set : Version_Set) return Generation;
end Generation_Operations;
package Reservation_Operations is
procedure Create_From_Db (Set : Version_Set;
Where : String;
Status : out Error_Status;
Gen : Generation := Last_Version);
procedure Create_From_Db (Set : Version_Set;
Where : Directory.Object;
Status : out Error_Status;
Gen : Generation := Last_Version);
-- Only works for objects of class 'file'
procedure Create_From_Db (Set : Version_Set;
To_File : in out Io.File_Type;
Status : out Error_Status;
Gen : Generation := Last_Version);
generic
with procedure Put_Line (Text : String);
procedure Create_From_Db_Generic (Set : Version_Set;
Status : out Error_Status;
Gen : Generation := Last_Version);
procedure Check_Out (Set : Version_Set;
Gen : out Generation;
Status : out Error_Status;
Config : Configuration;
User : String := "");
procedure Check_In (Set : Version_Set;
Current_Source : Directory.Object;
Gen : out Generation;
Status : out Error_Status;
Config : Configuration;
User : String := "");
-- Check out (or in) some element. Since the element is specified
-- by the version set, the element need not be provided. Check out
-- creates a new version. The configuration is changed to reflect
-- the use of the new version. Check in verifies the same
-- configuration is being used. The command package can check to see
-- if the user doing the check in is the same one that did the
-- check out.
-- Check out returns the generation for the new copy. The
-- generation can be used to locate a copy of the element on the
-- disk somewhere by using the last_known_object history item. The
-- application must copy this object to the destination. If the
-- last_known_object is Nil, the application should request a copy
-- to built out of the database, supplying the destination
-- location.
-- Check in wants the directory.object of the item being checked
-- in. It uses this to compute the differentials, and also saves it
-- in the database (for passing to the next check out). It returns
-- the generation for any later processing that might be needed
-- (like compiling or accepting).
-- The command package check in might also want to check for the
-- existence of a golden configuration, and copy the object there.
-- The resulting object would be given to check in. If a golden
-- configuration is desired, the returned generation should be
-- accepted into that golden configuration to bring that
-- configuration up to date. Remember to do all of the work
-- required before check in under one action, so the operations can
-- be backed out if the check in fails. The most common failure is
-- 'wrong configuration', so the command package might want to
-- check that itself first.
-- The user string is used to mark who did the operation. If "" is
-- supplied, the login name is used.
procedure Abandon_Reservation (Set : Version_Set;
Revert_To_Gen : Generation;
Status : out Error_Status;
Config : Configuration);
-- Abandon a previous check out operation. The checked out version
-- is thrown away. It is the command package's responsibility to
-- ensure that the version being reverted to is copied into the
-- appropriate place. The configuration is changed to refer to the
-- specified generation. Giving 'last_version' as the generation
-- will revert to the generation before the check out (as it is the
-- last after the revert).
procedure Accept_Changes (Set : Version_Set;
Result : out Generation;
Status : out Error_Status;
Gen : Generation := Last_Version;
Config : Configuration);
-- The configuration is changed to refer to the requested version.
-- The actual generation selected is returned. If the last version
-- is checked out, the last - 1 version is returned. The
-- configuration is changed to refer to the returned generation.
-- This operation can be reversed by accepting some other version.
-- It is the command package's responsibility to actually copy the
-- data.
end Reservation_Operations;
package Merge_Operations is
procedure Merge_Changes (Elem : Element;
From_Config : Configuration;
Conflicts_Detected : out Boolean;
Gen : out Generation;
Status : out Error_Status;
To_Config : Configuration;
List_File : String := "";
Join_Configs : Boolean := True;
User : String := "");
-- The versions in the two version sets selected by elem are merged
-- together, with the result being left in the to_config. This
-- operation always creates a new version. The to_config is marked
-- to refer to the new version. An error occurs if join_configs is true
-- and from_config doesn't refer to the last version in its version
-- set, or if to_config doesn't refer to the last version in its set.
-- This command requires that the two version sets be related,
-- which means that one of the sets must have been created from the
-- other. If the split point cannot be located, or never existed,
-- the merge fails.
-- If conflicting changes are found, the out parameter
-- conflicts_detected is set to true. This by itself is not an error
-- List_file specifies a text file where the merged result can be
-- placed. The merge points in the file are marked in the same
-- fashion as file_utilities.merge.
-- Effort_only will do the merge without actually updating the
-- database.
-- Join_configs, if true, will change from_config to refer to the
-- same version set as to_config. In other words, the two
-- configurations are relinked.
end Merge_Operations;
type Basic_History is
record
Ever_Checked_Out : Boolean;
When_Checked_Out : Calendar.Time;
Checked_Out_To_Config : Configuration;
Ever_Checked_In : Boolean;
When_Checked_In : Calendar.Time;
Expected_Check_In : Calendar.Time;
Edit_Time_Stamp : Calendar.Time;
Last_Known_Object : Directory.Object;
Split_From_Set : Version_Set;
Split_From_Version : Generation;
Merged_From_Set : Version_Set;
Merged_From_Version : Generation;
end record;
-- Split refers to the source version when the set was created. merged
-- refers to a version that was merged into this one.
-- Checked_out_to_config is nil if the config has been deleted.
package History_Operations is
procedure Get (Set : Version_Set;
History : out Basic_History;
Status : out Error_Status;
Gen : Generation := Last_Version);
-- Return the history for some generation in the set.
function Who_Checked_Out
(Set : Version_Set; Gen : Generation := Last_Version)
return String;
function Who_Checked_In
(Set : Version_Set; Gen : Generation := Last_Version)
return String;
-- Return the string history items
procedure Set_Expected_Check_In (Set : Version_Set;
To_Time : Calendar.Time;
Status : out Error_Status);
-- Change the expected check in time for the last generation of the set.
-- It must be checked out.
procedure Set_Last_Known_Object (Set : Version_Set;
To_Object : Directory.Object;
Status : out Error_Status;
Gen : Generation := Last_Version);
-- Set the last known object entry in the basic history for the specified
-- generation. It need not be checked out.
function Is_Checked_Out (Set : Version_Set) return Boolean;
-- simple way to see if a version is currently checked out
package What_Changed is
-- Compute the difference between two adjacent versions in a
-- version set. Make the text available for reporting.
type Region_Iterator is private;
type Region_Record is
record
Newer_Start_Line : Natural;
Newer_Stop_Line : Natural;
Older_Start_Line : Natural;
Older_Stop_Line : Natural;
end record;
-- The Newer_Start_Line and Newer_Stop_Line are line numbers of
-- the full text of the newer generation, and do not take into
-- account insertions, deletions, or replacements from the
-- older generation. These line numbers are always
-- the correct numbers to give to the text extraction
-- function below. Line numbers 1..Last_Newer_Line(iter) will
-- span the entire text of the newer generation.
-- Older_Start_Line and Older_Stop_Line are line numbers
-- within regions of difference and are not necessarily
-- actual line numbers within the older generation, but can
-- be used by the text extraction function to get the
-- text of the older generation within the difference regions.
-- The entirety of the older generation cannot be printed
-- by this package.
-- If newer_start > newer_stop, text from older_start to
-- older_stop has been deleted from between newer_stop
-- and newer_start.
-- If newer_start <= newer_stop and
-- If older_start > older_stop, text between newer_start
-- and newer_stop has been inserted.
-- or If older_start <= older_stop text is being replaced
-- Line numbers not mentioned in a region are common between the
-- two generations.
procedure Initialize (In_Set : Version_Set;
Result : out Region_Iterator;
Status : out Error_Status;
Generation_Pair : Generation := Last_Version);
-- Compute an iterator for differences between generation and
-- generation - 1.
function Done (Iter : Region_Iterator) return Boolean;
function Value (Iter : Region_Iterator) return Region_Record;
procedure Next (Iter : in out Region_Iterator);
function Last_Newer_Line (Iter : Region_Iterator) return Natural;
function Text_Of_Newer
(Iter : Region_Iterator; Line_Number : Natural)
return String;
function Text_Of_Older
(Iter : Region_Iterator; Line_Number : Natural)
return String;
private
type Region_Iterator_Record;
type Region_Iterator is access Region_Iterator_Record;
pragma Segmented_Heap (Region_Iterator);
end What_Changed;
procedure Set (From_File : in out Io.File_Type;
Set : Version_Set;
Status : out Error_Status);
-- Copy the text file to the history database, and
-- associate it with the last version in the version set. The version
-- must be checked out and not checked in.
procedure Append (From_File : in out Io.File_Type;
Set : Version_Set;
Status : out Error_Status);
-- Same as above, only the file is appended instead of replacing.
procedure Get (To_File : in out Io.File_Type;
Set : Version_Set;
Status : out Error_Status;
Gen : Generation := Last_Version);
-- Copy the history file from the database into a text file
procedure Set (From_String : String;
Set : Version_Set;
Status : out Error_Status);
-- Copy the string to the history database, and
-- associate it with the last version in the version set. The version
-- must be checked out and not checked in. Lines must be separated
-- by Ascii.Lf
procedure Append (From_String : String;
Set : Version_Set;
Status : out Error_Status);
-- Same as above, only the string is appended instead of replacing.
function Get (Set : Version_Set; Gen : Generation := Last_Version)
return String;
-- Return the history info from the database as a string. Lines
-- are separated by Ascii.Lf
end History_Operations;
package Iterator_Operations is
type Configuration_Iterator is private;
procedure Initialize (Db : Database; Iter : out Configuration_Iterator);
procedure Initialize (Elem : Element;
Iter : out Configuration_Iterator);
procedure Initialize (Set : Version_Set;
Iter : out Configuration_Iterator);
procedure Initialize (Set : Version_Set;
Up_To_Version : Generation;
Iter : out Configuration_Iterator);
procedure Next (Iter : in out Configuration_Iterator);
function Done (Iter : Configuration_Iterator) return Boolean;
function Value (Iter : Configuration_Iterator) return Configuration;
-- Iterate over configurations. The iterator can be built to iterate
-- over all configurations, all configurations that reference some
-- element, all configurations that reference some version set, or
-- all configurations that reference the first up to n'th version of
-- a version set.
type Element_Iterator is private;
procedure Initialize (Config : Configuration;
Iter : out Element_Iterator);
procedure Initialize (Db : Database; Iter : out Element_Iterator);
procedure Next (Iter : in out Element_Iterator);
function Done (Iter : Element_Iterator) return Boolean;
function Value (Iter : Element_Iterator) return Element;
-- Iterate over elements. The options are to iterate over all elements
-- in the database, or to iterate over all elements in a configuration.
type Version_Set_Iterator is private;
procedure Initialize (Db : Database; Iter : out Version_Set_Iterator);
procedure Initialize (Config : Configuration;
Iter : out Version_Set_Iterator);
procedure Initialize (Elem : Element; Iter : out Version_Set_Iterator);
procedure Next (Iter : in out Version_Set_Iterator);
function Done (Iter : Version_Set_Iterator) return Boolean;
function Value (Iter : Version_Set_Iterator) return Version_Set;
-- Iterate over the version sets specified by a configuration, over
-- the version sets associated with an element, or over all version
-- sets in the database. Iterating over version sets is useful for
-- finding an external name and matching it against the name of
-- some object, in order to find an element name. This would be
-- done by stripping off the library and then comparing what is
-- left to the external names for the version sets.
private
type Ci_Limit_Enumeration is (All_Configs, Elem_Limit, Set_Limit);
type Ci_Record (What_Sort : Ci_Limit_Enumeration);
type Configuration_Iterator is access Ci_Record;
pragma Segmented_Heap (Configuration_Iterator);
type Ei_Limit_Enumeration is (All_Elements, Config_Limit);
type Ei_Record (What_Sort : Ei_Limit_Enumeration);
type Element_Iterator is access Ei_Record;
pragma Segmented_Heap (Element_Iterator);
type Vsi_Limit_Enumeration is (All_Sets, Config_Limit, Elem_Limit);
type Vsi_Record (What_Sort : Vsi_Limit_Enumeration);
type Version_Set_Iterator is access Vsi_Record;
pragma Segmented_Heap (Version_Set_Iterator);
end Iterator_Operations;
private
type Database_Record;
type Database is access Database_Record;
pragma Segmented_Heap (Database);
type Configuration_Record;
type Configuration is access Configuration_Record;
pragma Segmented_Heap (Configuration);
type Element_Record;
type Element is access Element_Record;
pragma Segmented_Heap (Element);
type Vs_Record;
type Version_Set is access Vs_Record;
pragma Segmented_Heap (Version_Set);
end Cmvc_Implementation;package Cmvc_Implementation_Errors is
subtype Status is Natural range 0 .. 127;
Nil : constant Status := 0;
Successful : constant Status := 0;
Config_Is_Frozen : constant Status := 1;
Must_Have_Set_Name : constant Status := 2;
Resolve_Failed : constant Status := 3;
Must_Specify_Element : constant Status := 4;
Not_Just_One_Set : constant Status := 5;
Bogus_Parameters : constant Status := 6;
Element_Not_In_Configuration : constant Status := 7;
Must_Specify_Configuration : constant Status := 8;
Must_Specify_Database : constant Status := 9;
Bad_Class : constant Status := 10;
Must_Specify_Elem_And_Config : constant Status := 11;
Multiple_Databases_Specified : constant Status := 12;
Must_Specify_Elem_And_Db : constant Status := 13;
Cant_Upgrade_Open_Type : constant Status := 14;
Cant_Open_Db : constant Status := 15;
Cant_Create_Db : constant Status := 16;
No_Such_Version_Set : constant Status := 17;
No_Such_Element : constant Status := 18;
No_Such_Version : constant Status := 19;
Duplicate_Element_Name : constant Status := 20;
Duplicate_Set_Name : constant Status := 21;
No_Such_Configuration : constant Status := 22;
Duplicate_Configuration_Name : constant Status := 23;
Must_Specify_Version_Set : constant Status := 24;
Must_Specify_Set_And_Config : constant Status := 25;
Element_Already_In_Config : constant Status := 26;
Cannot_Open_Source_Object : constant Status := 27;
Cannot_Create_Target_Object : constant Status := 28;
Not_Checked_Out : constant Status := 29;
Set_Not_In_Configuration : constant Status := 30;
Not_A_Config_Obj : constant Status := 31;
Checked_Out_To_Other_Config : constant Status := 32;
Can_Delete_Only_End_Versions : constant Status := 33;
Duplicate_Class_Name : constant Status := 34;
Bad_Generation : constant Status := 35;
Bad_Generation_Pair : constant Status := 36;
Already_Checked_Out : constant Status := 37;
Cannot_Create_List_File : constant Status := 38;
Cannot_Close_Database : constant Status := 39;
Not_A_Database : constant Status := 40;
Unknown_Error : constant Status := 126;
Bad : constant Status := 127;
function Is_Bad (Stat : Status) return Boolean;
function Message (N : Status) return String;
Text_Creation_Storage_Error : constant Status := 41;
Database_Storage_Error : constant Status := 42;
No_Common_Ancestor_Found : constant Status := 43;
Source_Is_Checked_Out : constant Status := 44;
Destination_Is_Checked_Out : constant Status := 45;
Database_Was_Locked : constant Status := 46;
Database_Access_Control_Violation : constant Status := 47;
Source_Not_Saved_In_Database : constant Status := 48;
Line_Too_Long_For_Storage : constant Status := 49;
Source_Object_Is_Locked : constant Status := 50;
Source_Object_Is_Access_Protected : constant Status := 51;
-- End status codes
pragma Subsystem (Tools);
pragma Module_Name (4, 3761);
end Cmvc_Implementation_Errors;with Action;
with Calendar;
with Directory;
package Cmvc_Implementation_Utilities is
function Appropriate_Modification_Time
(Obj : Directory.Object; Action_Id : Action.Id)
return Calendar.Time;
-- return the time the unit was last modified. For Ada units, the
-- edit time is used. For others, the modified time is used.
procedure Analyze_Space (For_Subsystem : String := "<IMAGE>";
Do_Reservation_Token_Trace : Boolean := False);
-- Produce a report describing how space is used in the
-- cmvc_database indicated. If Do_Reservation_Token_Trace is
-- true, a (potentiall long) report is written showing by
-- Element which reservation_tokens (version sets) are defined
-- and which configurations reference them
procedure Enable_Page_Accounting (To_What : Boolean := False);
-- Turn on page tracing within the Cmvc_Database disk subsystem. The
-- result is a report of what pages were touched how many times
-- whenever a database is closed. This is system wide, and causes the
-- creation of garbage.
pragma Subsystem (Tools);
pragma Module_Name (4, 3762);
end Cmvc_Implementation_Utilities;package Compatibility is
pragma Subsystem (Compiler_Utilities);
pragma Module_Name (4, 2914);
procedure Display_Unit_Map (Subsystem : String := "<IMAGE>";
Header_Only : Boolean := False);
procedure Display_Declaration_Map
(Units : String := "<IMAGE>"; Header_Only : Boolean := False);
procedure Display_Offset_Map (Units : String := "<IMAGE>";
Header_Only : Boolean := False);
end Compatibility;with Machine;
with System;
package Default is
-- return Default information about the caller
function Get_Task_Id return Machine.Task_Id renames Machine.Get_Task_Id;
function Job return Machine.Job_Id;
function Session return Machine.Session_Id;
subtype Process_Id is Machine.Job_Id;
function "=" (L, R : Process_Id) return Boolean renames System."=";
Nil : constant Process_Id := Machine.Nil_Job;
function Process return Process_Id renames Job;
function Hash (Key : Process_Id := Process) return Integer;
pragma Subsystem (Om_Mechanisms);
pragma Module_Name (4, 910);
end Default;with System;
with Diana;
with Directory;
with Action;
package Dependency_Data_Base is
pragma Subsystem (Ada_Management, Private_Part => Closed);
pragma Module_Name (4, 1106);
type Total_Relationships is
(References_In_Use_Clause,
-- the id is referenced in a use clause in the unit.
References_Directly,
-- the unit is in the immediate scope of the id and references
-- the id as a simple name.
References_By_Selection_Within_Immediate_Scope,
-- the unit is in the immediate scope of the id, but references
-- the id as an expanded name.
References_By_Selection_Outside_Immediate_Scope,
-- the unit is outside the immediate scope of the id, and
-- references the id via an expanded name
Sees_Used_Namesake_Via_Use_Clause,
-- the unit is in the immediate scope of the id, but can reference
-- a used namesake as a simple name (made visible by a USE
-- clause). This relation is established only for place-holder
-- ids.
Subordinate_To,
-- <this comment left unintentionally blank>
References_Code_Segment
-- <this comment left unintentionally blank>
);
subtype Relationship is Total_Relationships
range Total_Relationships'First ..
Total_Relationships'Last;
pragma Consume_Offset (9);
subtype Heap_Type is System.Segment;
type Iterator is private;
function Objects (Relation : Relationship;
Id : Diana.Tree;
Action_Id : Action.Id;
Heap : Heap_Type) return Iterator;
function Objects (Relation : Relationship;
Ids : Diana.Temp_Seq;
Action_Id : Action.Id;
Heap : Heap_Type) return Iterator;
-- When relations are examined with the above entries, the
-- DDB will first obtain a read lock on the id(s) under the supplied
-- action id.
function Next (Iter : Iterator) return Iterator;
function Done (Iter : Iterator) return Boolean;
function Object_Id (Iter : Iterator) return Directory.Version;
pragma Consume_Offset (6);
function Subordinates (Id : Diana.Tree; Action_Id : Action.Id)
return Diana.Temp_Seq;
-- When subordinates are examined with the above entry, the
-- DDB will first obtain a read lock on the id under the supplied
-- action id.
pragma Consume_Offset;
Ddb_Lock_Error : exception;
Ddb_Other_Error : exception;
type Defid_Iterator is limited private;
procedure Init (Iter : out Defid_Iterator);
procedure Next (Iter : in out Defid_Iterator);
function Done (Iter : Defid_Iterator) return Boolean;
function Defid (Iter : Defid_Iterator) return Diana.Tree;
end Dependency_Data_Base;with System;
with Universal;
package Diana is
pragma Subsystem (Ada_Management);
pragma Module_Name (4, 1110);
-- Outline of Diana package
-- NODE_NAME type
-- TREE type
-- Lexical types and operations
-- List types and primitive operations
-- Constructors and generalized selectors for tree nodes
-- VALUE type and primitive operations
-- Selectors for structural attributes
-- Selectors for semantic attributes
-- Selectors for code attributes
-- Procedures for setting structural attributes
-- Procedures for setting semantic attributes
-- Procedures for setting code attributes
-- PERMANENT_ATTRIBUTES, mechanism for extensible user-defined attributes
-- TEMPORARY_ATTRIBUTES
-- STANDARD_PACKAGE, providing access to the tree for Standard
-- EDIT_UTILITIES for traversing and manipulating trees
-- LIST_UTILITIES for more powerful list operations
-- ID_UTILITIES for computing id lists and other id operations
-- SYMBOLIC_IO for dumping diana tree in symbolic form
-- TRAVERSAL provides generics for traversing trees
-- ATTR_NAMES
-- PRAGMA_NAMES
-- OPERATOR_NAMES
-- CHECK_NAMES
-- EXCEPTION_NAMES
-- constraint_error : exception;
-- indicates attempt to apply incorrect selector to a node.
Illegal_Structure : exception;
-- Indicates attempt to introduce structural sharing
---------------------------------------------------------------------------
type Node_Name is (Dn_Void, Dn_Aggregate, Dn_Deferred_Constant,
Dn_Allocator, Dn_Binary, Dn_Conversion, Dn_Membership,
Dn_Null_Access, Dn_Numeric_Literal, Dn_Parenthesized,
Dn_Qualified, Dn_String_Literal, Dn_Used_Char, Dn_All,
Dn_Attribute, Dn_Attribute_Call, Dn_Function_Call,
Dn_Indexed, Dn_Selected, Dn_Slice, Dn_Used_Op,
Dn_Used_Bltn_Op, Dn_Used_Object_Id, Dn_Used_Name_Id,
Dn_Used_Bltn_Id, Dn_Attr_Id, Dn_Pragma_Id,
Dn_Argument_Id, Dn_Comp_Id, Dn_Const_Id, Dn_Dscrmt_Id,
Dn_Entry_Id, Dn_Exception_Id, Dn_Function_Id,
Dn_Generic_Id, Dn_In_Id, Dn_In_Out_Id, Dn_Out_Id,
Dn_Iteration_Id, Dn_Label_Id, Dn_Number_Id,
Dn_Package_Id, Dn_Private_Type_Id, Dn_L_Private_Type_Id,
Dn_Proc_Id, Dn_Subtype_Id, Dn_Task_Body_Id, Dn_Type_Id,
Dn_Var_Id, Dn_Enum_Id, Dn_Def_Char, Dn_Def_Op, Dn_Box,
Dn_No_Default, Dn_Instantiation, Dn_Exception,
Dn_Constant, Dn_Var, Dn_Number, Dn_Type, Dn_Subtype,
Dn_Subprogram_Decl, Dn_Package_Decl, Dn_Task_Decl,
Dn_Pragma, Dn_Generic, Dn_Address, Dn_Record_Rep,
Dn_Simple_Rep, Dn_Use, Dn_Task_Body, Dn_Package_Body,
Dn_Subprogram_Body, Dn_Subunit, Dn_Loop, Dn_Abort,
Dn_Accept, Dn_Assign, Dn_Block, Dn_Case, Dn_Code,
Dn_Cond_Entry, Dn_Delay, Dn_Entry_Call, Dn_Exit, Dn_Goto,
Dn_If, Dn_Labeled, Dn_Named_Stm, Dn_Named_Stm_Id,
Dn_Null_Stm, Dn_Procedure_Call, Dn_Raise, Dn_Return,
Dn_Select, Dn_Terminate, Dn_Timed_Entry, Dn_Range,
Dn_Dscrmt_Aggregate, Dn_Dscrt_Range_S, Dn_Fixed,
Dn_Float, Dn_Constrained, Dn_Formal_Dscrt,
Dn_Formal_Fixed, Dn_Formal_Float, Dn_Formal_Integer,
Dn_Access, Dn_Array, Dn_Derived, Dn_Enum_Literal_S,
Dn_Integer, Dn_L_Private, Dn_Private, Dn_Record,
Dn_Task_Spec, Dn_Universal_Integer, Dn_Universal_Fixed,
Dn_Universal_Real, Dn_Stub, Dn_Pseudo_Stub, Dn_Entry,
Dn_Function, Dn_Procedure, Dn_Package_Spec,
Dn_Out, Dn_In, Dn_In_Out, Dn_Rename, Dn_For,
Dn_Reverse, Dn_While, Dn_Context, Dn_With, Dn_In_Op,
Dn_Not_In, Dn_Index, Dn_Alternative_S, Dn_Choice_S,
Dn_Comp_Rep_S, Dn_Decl_S, Dn_Exp_S, Dn_Generic_Assoc_S,
Dn_Generic_Param_S, Dn_Id_S, Dn_Item_S, Dn_Name_S,
Dn_Param_Assoc_S, Dn_Param_S, Dn_Pragma_S,
Dn_Select_Clause_S, Dn_Stm_S, Dn_Variant_S,
Dn_Dscrmt_Var_S, Dn_Variant, Dn_Dscrmt_Var,
Dn_And_Then, Dn_Or_Else, Dn_Select_Clause,
Dn_Alternative, Dn_Comp_Rep, Dn_Cond_Clause,
Dn_Inner_Record, Dn_Compilation, Dn_Others, Dn_Null_Comp,
Dn_Variant_Part, Dn_Named, Dn_Comp_Unit, Dn_Assoc,
Dn_Alignment, Dn_Nonterminal, Dn_Foo1, Dn_Foo2);
---------------------------------------------------------------------------
-- basic node type
type Tree is private;
pragma Cache_Register (Tree, 12);
function Get_Segment (T : Tree) return System.Segment;
function Get_Offset (T : Tree) return System.Bit_Offset;
function Empty return Tree; -- returns a constant void node
function Is_Empty (T : Tree) return Boolean;
function Kind (T : Tree) return Node_Name;
function Is_Id_Node (Name : Node_Name) return Boolean;
function Is_Id_Node (T : Tree) return Boolean;
function Hash (T : Tree) return Integer;
function Hash (T : Tree) return Long_Integer;
pragma Consume_Offset;
---------------------------------------------------------------------------
-- Types introduced to allow implementation of user-defined attributes
-- to be visible in the body of diana.
type Attr_Name is private;
function Equal (X, Y : Attr_Name) return Boolean;
pragma Consume_Offset;
function Get_Segment (A : Attr_Name) return System.Segment;
function Get_Offset (A : Attr_Name) return System.Bit_Offset;
type Attr_List is private;
pragma Cache_Register (Attr_List, 18);
pragma Consume_Offset;
function Get_Segment (A : Attr_List) return System.Segment;
function Get_Offset (A : Attr_List) return System.Bit_Offset;
---------------------------------------------------------------------------
-- Lexical types and operations
type Symbol_Rep is private;
pragma Cache_Register (Symbol_Rep, 13);
pragma Consume_Offset;
function Get_Segment (S : Symbol_Rep) return System.Segment;
function Get_Offset (S : Symbol_Rep) return System.Bit_Offset;
function Null_Text return Symbol_Rep;
function Equal (X, Y : Symbol_Rep) return Boolean;
function Lx_Symrep (T : Tree) return Symbol_Rep;
function Id (T : Tree) return Symbol_Rep renames Lx_Symrep;
procedure Lx_Symrep (T : Tree; V : Symbol_Rep);
procedure Lx_Symrep (T : Tree; V : String);
function Image (Symbol : Symbol_Rep) return String;
function Symrep (Image : String) return Symbol_Rep;
pragma Consume_Offset (2);
function Length (Symbol : Symbol_Rep) return Natural;
function Ith (Symbol : Symbol_Rep; Position : Natural) return Character;
function Hash (Symbol : Symbol_Rep) return Integer;
---------------------------------------------------------------------------
type Number_Rep is private;
pragma Consume_Offset;
function Get_Segment (N : Number_Rep) return System.Segment;
function Get_Offset (N : Number_Rep) return System.Bit_Offset;
function Equal (X, Y : Number_Rep) return Boolean;
function Lx_Numrep (T : Tree) return Number_Rep;
procedure Lx_Numrep (T : Tree; V : Number_Rep);
function Image (Number : Number_Rep) return String;
function Numrep (Image : String) return Number_Rep;
pragma Consume_Offset (2);
function Length (Number : Number_Rep) return Natural;
function Ith (Number : Number_Rep; Position : Natural) return Character;
procedure Lx_Prefix (T : Tree; V : Boolean);
function Lx_Prefix (T : Tree) return Boolean;
procedure Lx_Default (T : Tree; V : Boolean);
function Lx_Default (T : Tree) return Boolean;
procedure Lx_Separate (T : Tree; V : Boolean);
function Lx_Separate (T : Tree) return Boolean;
---------------------------------------------------------------------------
type Comment is private;
function Get_Segment (C : Comment) return System.Segment;
function Get_Offset (C : Comment) return System.Bit_Offset;
function Make (Text : String;
Start_Column : Natural;
Trailing_Page_Marks : Natural := 0;
Trailing_Line_Marks : Natural := 0) return Comment;
function Text (C : Comment) return String;
function Start_Column (C : Comment) return Natural;
function Trailing_Page_Marks (C : Comment) return Natural;
function Trailing_Line_Marks (C : Comment) return Natural;
procedure Text (C : Comment; Value : String);
procedure Start_Column (C : Comment; Value : Natural);
procedure Trailing_Page_Marks (C : Comment; Value : Natural);
procedure Trailing_Line_Marks (C : Comment; Value : Natural);
---------------------------------------------------------------------------
-- Structural list type
type Seq_Type is private;
pragma Cache_Register (Seq_Type, 14);
function Get_Segment (S : Seq_Type) return System.Segment;
function Get_Offset (S : Seq_Type) return System.Bit_Offset;
function Hash (S : Seq_Type) return Integer;
function Make return Seq_Type;
function Is_Empty (S : Seq_Type) return Boolean;
function Head (L : Seq_Type) return Tree;
function Tail (L : Seq_Type) return Seq_Type;
function Cons (T : Tree; L : Seq_Type) return Seq_Type;
procedure Replace_Head (L : in out Seq_Type; T : Tree);
procedure Replace_Tail (L1 : Seq_Type; L2 : Seq_Type);
pragma Consume_Offset;
---------------------------------------------------------------------------
-- Non-structural list type
type Sequence is private;
pragma Cache_Register (Sequence, 15);
function Get_Segment (S : Sequence) return System.Segment;
function Get_Offset (S : Sequence) return System.Bit_Offset;
function Hash (S : Sequence) return Integer;
function Make return Sequence;
function Is_Empty (L : Sequence) return Boolean;
function Head (L : Sequence) return Tree;
function Tail (L : Sequence) return Sequence;
function Cons (T : Tree; L : Sequence) return Sequence;
function Cons (T : Tree; L : Sequence; In_Segment : System.Segment)
return Sequence;
procedure Replace_Head (L : Sequence; T : Tree);
procedure Replace_Tail (L1 : Sequence; L2 : Sequence);
pragma Consume_Offset;
---------------------------------------------------------------------------
-- list type which is not allocated in diana heap
type Temp_Seq is private;
pragma Cache_Register (Temp_Seq, 17);
function Get_Segment (S : Temp_Seq) return System.Segment;
function Get_Offset (S : Temp_Seq) return System.Bit_Offset;
function Hash (S : Temp_Seq) return Integer;
function Make return Temp_Seq;
function Is_Empty (L : Temp_Seq) return Boolean;
function Head (L : Temp_Seq) return Tree;
function Tail (L : Temp_Seq) return Temp_Seq;
function Cons (T : Tree; L : Temp_Seq) return Temp_Seq;
function Cons (T : Tree; L : Temp_Seq; In_Segment : System.Segment)
return Temp_Seq;
procedure Replace_Head (L : Temp_Seq; T : Tree);
procedure Replace_Tail (L1 : Temp_Seq; L2 : Temp_Seq);
---------------------------------------------------------------------------
-- constructor functions for diana nodes
function Make (C : Node_Name) return Tree;
function Make (C : Node_Name; V : Symbol_Rep) return Tree;
function Make (C : Node_Name; V : String) return Tree;
function Make (C : Node_Name; V : Boolean) return Tree;
function Make (C : Node_Name; T1 : Tree) return Tree;
function Make (C : Node_Name; T1, T2 : Tree) return Tree;
function Make (C : Node_Name; T1, T2, T3 : Tree) return Tree;
function Make (C : Node_Name; L : Seq_Type) return Tree;
function Make (L : Sequence) return Tree; -- returns dn_exp_s
function Make (C : Node_Name; In_Segment : System.Segment) return Tree;
---------------------------------------------------------------------------
type Arities is (Nullary, Unary, Binary, Ternary, Arbitrary);
function Arity (T : Tree) return Arities;
function Arity (N : Node_Name) return Arities;
-- general selectors for subnodes
function Child1 (T : Tree) return Tree;
function Child2 (T : Tree) return Tree;
function Child3 (T : Tree) return Tree;
function List (T : Tree) return Seq_Type;
function As_List (T : Tree) return Seq_Type renames List;
function Son1 (T : Tree) return Tree renames Child1;
function Son2 (T : Tree) return Tree renames Child2;
function Son3 (T : Tree) return Tree renames Child3;
-- changing subnodes
procedure Child1 (T : Tree; V : Tree);
procedure Child2 (T : Tree; V : Tree);
procedure Child3 (T : Tree; V : Tree);
procedure List (T : Tree; V : Seq_Type);
procedure As_List (T : Tree; V : Seq_Type) renames List;
procedure Son1 (T : Tree; V : Tree) renames Child1;
procedure Son2 (T : Tree; V : Tree) renames Child2;
procedure Son3 (T : Tree; V : Tree) renames Child3;
---------------------------------------------------------------------------
-- Implementation defined Value type
type Value_Kind is (Integer_Valued, Float_Valued, No_Value, Uninitialized);
type Value is private;
function Equal (V1, V2 : Value) return Boolean;
function Kind (V : Value) return Value_Kind;
function Make return Value; -- returns value'(kind=>no_value);
function Make (I : Integer) return Value;
function Make (F : Float) return Value;
function Make (I : Universal.Integer) return Value;
function Make (F : Universal.Float) return Value;
function Make (F : Universal.Real) return Value;
function Integer_Value (V : Value) return Universal.Integer;
function Float_Value (V : Value) return Universal.Float;
function Float_Value (V : Value) return Universal.Real;
procedure Integer_Value (V : in out Value; I : Universal.Integer);
procedure Float_Value (V : in out Value; F : Universal.Float);
procedure Float_Value (V : in out Value; F : Universal.Real);
function Is_Integer (V : Value) return Boolean;
function Is_Float (V : Value) return Boolean;
function Is_No_Value (V : Value) return Boolean;
function Make (I : Integer) return Tree;
function Make (F : Float) return Tree;
function Make (I : Universal.Integer) return Tree;
function Make (F : Universal.Float) return Tree;
function Make (F : Universal.Real) return Tree;
-- construct dn_numeric_literal with appropriate value
function Is_Integer (T : Tree) return Boolean;
function Is_Float (T : Tree) return Boolean;
function Integer_Value (T : Tree) return Universal.Integer;
function Float_Value (T : Tree) return Universal.Float;
function Float_Value (T : Tree) return Universal.Real;
---------------------------------------------------------------------------
-- selector functions for structural attributes
function As_Actual (T : Tree) return Tree;
function As_Alignment (T : Tree) return Tree;
function As_Alternative_S (T : Tree) return Tree;
function As_Binary_Op (T : Tree) return Tree;
function As_Block_Stub (T : Tree) return Tree;
function As_Choice_S (T : Tree) return Tree;
function As_Comp_Rep_S (T : Tree) return Tree;
function As_Constrained (T : Tree) return Tree;
function As_Constraint (T : Tree) return Tree;
function As_Context (T : Tree) return Tree;
function As_Decl_S (T : Tree) return Tree;
function As_Decl_S1 (T : Tree) return Tree;
function As_Decl_S2 (T : Tree) return Tree;
function As_Designator (T : Tree) return Tree;
function As_Designator_Char (T : Tree) return Tree;
function As_Dscrt_Range (T : Tree) return Tree;
function As_Dscrt_Range_S (T : Tree) return Tree;
function As_Dscrt_Range_Void (T : Tree) return Tree;
function As_Exception_Def (T : Tree) return Tree;
function As_Exp (T : Tree) return Tree;
function As_Exp1 (T : Tree) return Tree;
function As_Exp2 (T : Tree) return Tree;
function As_Exp_Constrained (T : Tree) return Tree;
function As_Exp_S (T : Tree) return Tree;
function As_Exp_Void (T : Tree) return Tree;
function As_Generic_Assoc_S (T : Tree) return Tree;
function As_Generic_Header (T : Tree) return Tree;
function As_Generic_Param_S (T : Tree) return Tree;
function As_Header (T : Tree) return Tree;
function As_Id (T : Tree) return Tree;
function As_Id_S (T : Tree) return Tree;
function As_Item_S (T : Tree) return Tree;
function As_Iteration (T : Tree) return Tree;
function As_Membership_Op (T : Tree) return Tree;
function As_Name (T : Tree) return Tree;
function As_Name_S (T : Tree) return Tree;
function As_Name_Void (T : Tree) return Tree;
function As_Object_Def (T : Tree) return Tree;
function As_Package_Def (T : Tree) return Tree;
function As_Param_Assoc_S (T : Tree) return Tree;
function As_Param_S (T : Tree) return Tree;
function As_Pragma_S (T : Tree) return Tree;
function As_Range (T : Tree) return Tree;
function As_Range_Void (T : Tree) return Tree;
function As_Record (T : Tree) return Tree;
function As_Select_Clause_S (T : Tree) return Tree;
function As_Stm (T : Tree) return Tree;
function As_Stm_S (T : Tree) return Tree;
function As_Stm_S1 (T : Tree) return Tree;
function As_Stm_S2 (T : Tree) return Tree;
function As_Subprogram_Def (T : Tree) return Tree;
function As_Subunit_Body (T : Tree) return Tree;
function As_Task_Def (T : Tree) return Tree;
function As_Type_Range (T : Tree) return Tree;
function As_Type_Spec (T : Tree) return Tree;
function As_Unit_Body (T : Tree) return Tree;
function As_Variant_S (T : Tree) return Tree;
function As_Dscrmt_Var_S (T : Tree) return Tree;
function As_Parent (T : Tree) return Tree;
---------------------------------------------------------------------------
-- selectors for semantic attributes
function Sm_List (Exp_S : Tree) return Sequence;
function Sm_Bits (T : Tree) return Integer;
function Sm_Pos (T : Tree) return Integer;
function Sm_Rep (T : Tree) return Integer;
function Sm_Controlled (T : Tree) return Boolean;
function Sm_Packing (T : Tree) return Boolean;
function Sm_Actual_Delta (T : Tree) return Universal.Float;
function Sm_Actual_Delta (T : Tree) return Universal.Real;
function Sm_Value (T : Tree) return Value;
function Sm_Address (T : Tree) return Tree;
function Sm_Base_Type (T : Tree) return Tree;
function Sm_Body (T : Tree) return Tree;
function Sm_Constraint (T : Tree) return Tree;
function Sm_Defn (T : Tree) return Tree;
function Sm_Discriminants (T : Tree) return Tree;
function Sm_Exp_Type (T : Tree) return Tree;
function Sm_Exception_Def (T : Tree) return Tree;
function Sm_Generic_Param_S (T : Tree) return Tree;
function Sm_Init_Exp (T : Tree) return Tree;
function Sm_Location (T : Tree) return Tree;
function Sm_Obj_Def (T : Tree) return Tree;
function Sm_Obj_Type (T : Tree) return Tree;
function Sm_Size (T : Tree) return Tree;
function Sm_Spec (T : Tree) return Tree;
function Sm_Stm (T : Tree) return Tree;
function Sm_Storage_Size (T : Tree) return Tree;
function Sm_Type_Spec (T : Tree) return Tree;
function Sm_Type_Struct (T : Tree) return Tree;
function Sm_Comp_Spec (T : Tree) return Tree;
function Sm_Decl_S (T : Tree) return Tree;
function Sm_First (T : Tree) return Tree;
function Sm_Normalized_Param_S (T : Tree) return Tree;
function Sm_Stub (T : Tree) return Tree;
function Sm_Record_Spec (T : Tree) return Tree;
function Sm_Normalized_Comp_S (T : Tree) return Tree;
function Sm_Parent (T : Tree) return Tree;
function Sm_Ops (T : Tree) return Sequence;
-- selectors for code attributes
function Cd_Impl_Size (T : Tree) return Integer;
---------------------------------------------------------------------------
-- procedures for setting structural attributes
procedure As_Actual (T : Tree; V : Tree);
procedure As_Alignment (T : Tree; V : Tree);
procedure As_Alternative_S (T : Tree; V : Tree);
procedure As_Binary_Op (T : Tree; V : Tree);
procedure As_Block_Stub (T : Tree; V : Tree);
procedure As_Choice_S (T : Tree; V : Tree);
procedure As_Comp_Rep_S (T : Tree; V : Tree);
procedure As_Constrained (T : Tree; V : Tree);
procedure As_Constraint (T : Tree; V : Tree);
procedure As_Context (T : Tree; V : Tree);
procedure As_Decl_S (T : Tree; V : Tree);
procedure As_Decl_S1 (T : Tree; V : Tree);
procedure As_Decl_S2 (T : Tree; V : Tree);
procedure As_Designator (T : Tree; V : Tree);
procedure As_Designator_Char (T : Tree; V : Tree);
procedure As_Dscrt_Range (T : Tree; V : Tree);
procedure As_Dscrt_Range_S (T : Tree; V : Tree);
procedure As_Dscrt_Range_Void (T : Tree; V : Tree);
procedure As_Exception_Def (T : Tree; V : Tree);
procedure As_Exp (T : Tree; V : Tree);
procedure As_Exp1 (T : Tree; V : Tree);
procedure As_Exp2 (T : Tree; V : Tree);
procedure As_Exp_Constrained (T : Tree; V : Tree);
procedure As_Exp_S (T : Tree; V : Tree);
procedure As_Exp_Void (T : Tree; V : Tree);
procedure As_Generic_Assoc_S (T : Tree; V : Tree);
procedure As_Generic_Header (T : Tree; V : Tree);
procedure As_Generic_Param_S (T : Tree; V : Tree);
procedure As_Header (T : Tree; V : Tree);
procedure As_Id (T : Tree; V : Tree);
procedure As_Id_S (T : Tree; V : Tree);
procedure As_Item_S (T : Tree; V : Tree);
procedure As_Iteration (T : Tree; V : Tree);
procedure As_Membership_Op (T : Tree; V : Tree);
procedure As_Name (T : Tree; V : Tree);
procedure As_Name_S (T : Tree; V : Tree);
procedure As_Name_Void (T : Tree; V : Tree);
procedure As_Object_Def (T : Tree; V : Tree);
procedure As_Package_Def (T : Tree; V : Tree);
procedure As_Param_Assoc_S (T : Tree; V : Tree);
procedure As_Param_S (T : Tree; V : Tree);
procedure As_Pragma_S (T : Tree; V : Tree);
procedure As_Range (T : Tree; V : Tree);
procedure As_Range_Void (T : Tree; V : Tree);
procedure As_Record (T : Tree; V : Tree);
procedure As_Select_Clause_S (T : Tree; V : Tree);
procedure As_Stm (T : Tree; V : Tree);
procedure As_Stm_S (T : Tree; V : Tree);
procedure As_Stm_S1 (T : Tree; V : Tree);
procedure As_Stm_S2 (T : Tree; V : Tree);
procedure As_Subprogram_Def (T : Tree; V : Tree);
procedure As_Subunit_Body (T : Tree; V : Tree);
procedure As_Task_Def (T : Tree; V : Tree);
procedure As_Type_Range (T : Tree; V : Tree);
procedure As_Type_Spec (T : Tree; V : Tree);
procedure As_Unit_Body (T : Tree; V : Tree);
procedure As_Variant_S (T : Tree; V : Tree);
procedure As_Dscrmt_Var_S (T : Tree; V : Tree);
---------------------------------------------------------------------------
-- procedures for setting semantic attributes
procedure Sm_Bits (T : Tree; V : Integer);
procedure Sm_Pos (T : Tree; V : Integer);
procedure Sm_Rep (T : Tree; V : Integer);
procedure Sm_Controlled (T : Tree; V : Boolean);
procedure Sm_Packing (T : Tree; V : Boolean);
procedure Sm_Actual_Delta (T : Tree; V : Universal.Float);
procedure Sm_Actual_Delta (T : Tree; V : Universal.Real);
procedure Sm_Value (T : Tree; V : Value);
procedure Sm_Address (T : Tree; V : Tree);
procedure Sm_Base_Type (T : Tree; V : Tree);
procedure Sm_Body (T : Tree; V : Tree);
procedure Sm_Constraint (T : Tree; V : Tree);
procedure Sm_Defn (T : Tree; V : Tree);
procedure Sm_Discriminants (T : Tree; V : Tree);
procedure Sm_Exp_Type (T : Tree; V : Tree);
procedure Sm_Exception_Def (T : Tree; V : Tree);
procedure Sm_Generic_Param_S (T : Tree; V : Tree);
procedure Sm_Init_Exp (T : Tree; V : Tree);
procedure Sm_Location (T : Tree; V : Tree);
procedure Sm_Obj_Def (T : Tree; V : Tree);
procedure Sm_Obj_Type (T : Tree; V : Tree);
procedure Sm_Size (T : Tree; V : Tree);
procedure Sm_Spec (T : Tree; V : Tree);
procedure Sm_Stm (T : Tree; V : Tree);
procedure Sm_Storage_Size (T : Tree; V : Tree);
procedure Sm_Type_Spec (T : Tree; V : Tree);
procedure Sm_Type_Struct (T : Tree; V : Tree);
procedure Sm_Comp_Spec (T : Tree; V : Tree);
procedure Sm_Decl_S (T : Tree; V : Tree);
procedure Sm_First (T : Tree; V : Tree);
procedure Sm_Normalized_Param_S (T : Tree; V : Tree);
procedure Sm_Stub (T : Tree; V : Tree);
procedure Sm_Record_Spec (T : Tree; V : Tree);
procedure Sm_Normalized_Comp_S (T : Tree; V : Tree);
procedure Sm_Parent (T : Tree; V : Tree);
procedure Sm_Ops (T : Tree; S : Sequence);
-- procedures for setting code attributes
procedure Cd_Impl_Size (T : Tree; V : Integer);
---------------------------------------------------------------------------
package Id_Table is
-- ID_TABLE provides a mapping between DIANA.SYMBOL_REPS and
-- DEF_IDs having that symbol representation in the context
-- associated with the ID_TABLE.
-- For the purpose of semantic analysis, id tables are attached
-- to the following list headers and provide efficient random access
-- (via symbol rep) to the declarations therein.
-- Node Contents
-- DECL_S package visible and private specs
-- and task specs
-- ITEM_S decls (including labels and statement ids)
-- within blocks (including
-- program unit bodies)
-- RECORD all discriminants and fields of record
-- PARAM_S parameters
-- GENERIC_PARAM_S generic parameters
-- DSCRMT_VAR_S discriminant vars of private type
type Id_Map is private;
Null_Table : constant Id_Map;
procedure Create (Mumble_S : Diana.Tree);
procedure Create (Mumble_S : Diana.Tree; Of_Size : Integer);
procedure Enter (Mumble_S : Diana.Tree; Defn : Diana.Tree);
procedure Enter (Mumble_S : Diana.Tree; Defns : Diana.Sequence);
procedure Enter (Mumble_S : Diana.Tree; Defns : Diana.Seq_Type);
-- DEFN(S) is a (list of) def id(s).
procedure Enter_New (Mumble_S : Diana.Tree; Defn : Diana.Tree);
-- enter an id from an incrementally inserted decl
procedure Remove (Mumble_S, Defn_Or_Decl : Diana.Tree);
-- DEFN(S) is a (list of) def id(s).
procedure Remove (Decl : Diana.Tree);
-- Decl must be rooted on the list of a decl_s, item_s, param_s,
-- generic_param_s, or record.
function Identify (Mumble_S : Diana.Tree;
Symbol : Diana.Symbol_Rep;
Stop_Decl : Diana.Tree) return Diana.Sequence;
function Identify (Mumble_S : Diana.Tree; Symbol : Diana.Symbol_Rep)
return Diana.Sequence;
function Identify (Mumble_S : Diana.Tree;
Symbol : Diana.Symbol_Rep;
Stop_Decl : Diana.Tree) return Diana.Tree;
function Identify (Mumble_S : Diana.Tree; Symbol : Diana.Symbol_Rep)
return Diana.Tree;
function Identify (Mumble_S : Diana.Tree;
Name : String;
Stop_Decl : Diana.Tree) return Diana.Sequence;
-- IDENTIFY returns the DEFN_IDs associated with the given SYMBOL from
-- the given table.
-- The form returning a single node, returns an arbitrary node
-- associated with the symbol and should be used only when one can
-- guarantee that at most one association could exist.
-- A null value is returned if no association exists.
-- If a STOP_DECL is given, only those associations that were
-- established "before" the given STOP_DECL are retrieved.
-- The ordering of ids in the table is the order of declaration
-- in the underlying MUMBLE_S (or ITEM_S).
function Identify_Wild (Mumble_S : Diana.Tree;
Symbol : Diana.Symbol_Rep;
Seen : Diana.Temp_Seq;
Stop_Decl : Diana.Tree := Diana.Empty)
return Diana.Temp_Seq;
function All_Ids (Mumble_S, Stop_Decl : Diana.Tree)
return Diana.Temp_Seq;
function All_Ids (Mumble_S : Diana.Tree) return Diana.Temp_Seq;
function Copy (Table : Id_Map) return Id_Map;
generic
with function Translate (Def_Id : Diana.Tree) return Diana.Tree;
procedure Convert (Table : Id_Map);
function All_Ids (Mumble_S, Stop_Decl : Diana.Tree)
return Diana.Sequence;
function All_Ids (Mumble_S : Diana.Tree) return Diana.Sequence;
function Header_Size (M : Id_Map) return Integer;
function Links_Size (M : Id_Map) return Integer;
function Total_Size (M : Id_Map) return Integer;
function Sequence_Nodes (M : Id_Map) return Integer;
type Local_Id_Table is private;
function Xlate (T : Local_Id_Table) return Id_Map;
function Xlate (T : Id_Map) return Local_Id_Table;
generic
with function Translate (Def_Id : Diana.Tree) return Diana.Tree;
procedure Convert_Table (Old_Table, New_Table : Id_Map);
private
type Id_Map_Head;
type Id_Map is access Id_Map_Head;
pragma Segmented_Heap (Id_Map);
type Local_Id_Table is new Id_Map;
pragma Short_Pointer (Local_Id_Table);
Null_Table : constant Id_Map := null;
for Local_Id_Table'Size use 26;
end Id_Table;
---------------------------------------------------------------------------
package Permanent_Attributes is
-- This is the low-level package for user-defined attributes.
-- Usage of this package should be limited to small packages
-- defining abstract user-defined attributes. Implementation
-- of the abstract user-defined attributes must be in terms of
-- the limited set of types provided here. More complex user-defined
-- attributes (which are not directly representable as integers, trees,
-- lists, etc.) may be implemented by using one of the simple types
-- provided here for a key and having the package which encapsulates the
-- the implementation of the user defined attribute do a mapping from
-- the low-level type to a more appropriate type. Note that in
-- this case the Ada Object Manager is only storing the handle or key
-- that is stored on the attribute list; the implementation
-- of the user defined attribute must provide storage facilities if
-- the attribute is to be a permanent attribute.
-- WARNING!!! Failure to follow these instructions may result in
-- maintenance problems. This package is exporting low-level
-- unencapsulated operations that are subject to change. Scattering
-- usage of this package through millions of lines of code is strongly
-- discouraged. Proper encapsulation of the definition of all
-- user-defined attributes will minimize the impact of such changes,
-- and may result in the Diana-hackers actually doing the maintenance
-- for you.
type Attr_Sort is (Tree_Attr, Sequence_Attr, Symbol_Rep_Attr,
Integer_Attr, Float_Attr, Boolean_Attr,
Short_Integer_Attr, Byte_Attr,
Universal_Integer_Attr, Universal_Real_Attr,
Comment_Attr, List_Attr, Id_Table_Attr);
subtype Name is Attr_Name;
function Equal (X, Y : Name) return Boolean renames Diana.Equal;
function Hash (Attr : Attr_Name) return Integer;
function Permanent_Attr_Name (Image : String) return Name;
function Predefined_Attr_Name (Image : String) return Name;
type Attr_Class is (Predefined, Permanent);
function Class (Attr : Attr_Name) return Attr_Class;
function Image (Attr : Name) return String;
function Symbol (Attr : Name) return Symbol_Rep;
subtype List is Attr_List;
function Attrs (Node : Tree) return List;
function Hash (L : List) return Integer;
subtype Id_Table is Diana.Id_Table.Id_Map;
type Short_Integer is range -(2 ** 15 - 1) .. 2 ** 15 - 1;
type Byte is range 0 .. 2 ** 8 - 1;
function Get (Node : Tree; Attr : Name) return Tree;
function Get (Node : Tree; Attr : Name) return Sequence;
function Get (Node : Tree; Attr : Name) return Symbol_Rep;
function Get (Node : Tree; Attr : Name) return Boolean;
function Get (Node : Tree; Attr : Name) return Integer;
function Get (Node : Tree; Attr : Name) return Float;
function Get (Node : Tree; Attr : Name) return Short_Integer;
function Get (Node : Tree; Attr : Name) return Byte;
function Get (Node : Tree; Attr : Name) return Universal.Integer;
function Get (Node : Tree; Attr : Name) return Universal.Real;
function Get (Node : Tree; Attr : Name) return Comment;
function Get (Node : Tree; Attr : Name) return List;
function Get (Node : Tree; Attr : Name) return Id_Table;
procedure Add (Node : Tree; Attr : Name; V : Tree);
procedure Add (Node : Tree; Attr : Name; V : Sequence);
procedure Add (Node : Tree; Attr : Name; V : Symbol_Rep);
procedure Add (Node : Tree; Attr : Name; V : Boolean);
procedure Add (Node : Tree; Attr : Name; V : Float);
procedure Add (Node : Tree; Attr : Name; V : Integer);
procedure Add (Node : Tree; Attr : Name; V : Short_Integer);
procedure Add (Node : Tree; Attr : Name; V : Byte);
procedure Add (Node : Tree; Attr : Name; V : Universal.Integer);
procedure Add (Node : Tree; Attr : Name; V : Universal.Real);
procedure Add (Node : Tree; Attr : Name; V : Comment);
procedure Add (Node : Tree; Attr : Name; V : List);
procedure Add (Node : Tree; Attr : Name; V : Id_Table);
function Has (Node : Tree; Attr : Name) return Boolean;
procedure Remove (Node : Tree; Attr : Name);
function Nil return List;
function Is_Empty (Attrs : List) return Boolean;
function Cons (Head : Tree; Attrs : List) return List;
function Cons (Head : Sequence; Attrs : List) return List;
function Cons (Head : Symbol_Rep; Attrs : List) return List;
function Cons (Head : Boolean; Attrs : List) return List;
function Cons (Head : Float; Attrs : List) return List;
function Cons (Head : Integer; Attrs : List) return List;
function Cons (Head : Short_Integer; Attrs : List) return List;
function Cons (Head : Byte; Attrs : List) return List;
function Cons (Head : Universal.Integer; Attrs : List) return List;
function Cons (Head : Universal.Real; Attrs : List) return List;
function Cons (Head : Comment; Attrs : List) return List;
function Cons (Head : Id_Table; Attrs : List) return List;
function Cons (Head : List; Attrs : List) return List;
function Kind (Attrs : List) return Attr_Sort;
function Get_Name (Attrs : List) return Name;
-- returns the kind/name of the first element of the list.
function Head (Attrs : List) return Tree;
function Head (Attrs : List) return Sequence;
function Head (Attrs : List) return Symbol_Rep;
function Head (Attrs : List) return Boolean;
function Head (Attrs : List) return Float;
function Head (Attrs : List) return Integer;
function Head (Attrs : List) return Short_Integer;
function Head (Attrs : List) return Byte;
function Head (Attrs : List) return Universal.Integer;
function Head (Attrs : List) return Universal.Real;
function Head (Attrs : List) return Id_Table;
function Head (Attrs : List) return Comment;
function Head (Attrs : List) return List;
function Tail (Attrs : List) return List;
procedure Replace_Head (Attrs : in out List; V : Tree);
procedure Replace_Head (Attrs : in out List; V : Sequence);
procedure Replace_Head (Attrs : in out List; V : Symbol_Rep);
procedure Replace_Head (Attrs : in out List; V : Boolean);
procedure Replace_Head (Attrs : in out List; V : Float);
procedure Replace_Head (Attrs : in out List; V : Integer);
procedure Replace_Head (Attrs : in out List; V : Short_Integer);
procedure Replace_Head (Attrs : in out List; V : Byte);
procedure Replace_Head (Attrs : in out List; V : Universal.Integer);
procedure Replace_Head (Attrs : in out List; V : Universal.Real);
procedure Replace_Head (Attrs : in out List; V : Id_Table);
procedure Replace_Head (Attrs : in out List; V : Comment);
procedure Replace_Head (Attrs : in out List; V : List);
procedure Replace_Tail (L1, L2 : List);
end Permanent_Attributes;
---------------------------------------------------------------------------
package Edit_Utilities is
function Copy (T : Tree) return Tree;
-- copy a node including all its attributes and subtrees.
function Copy (L : Seq_Type) return Seq_Type;
-- copy a list - will copy all trees in the list.
procedure Remove (T : Tree; Detach : Boolean := True);
-- remove a tree from its parent.
-- If DETACH is false, then the pointers in T will not be
-- reset, and the resulting list structure will be illegal
-- due to sharing. Any further operations on T are likely
-- to fail in unpleasant ways.
procedure Remove (L : Seq_Type);
-- remove a tree from its parent.
procedure Exchange (T1, T2 : Tree);
-- replaces T1 by T2 and T2 by T1, updating backpointers and parents.
function Copy (S : Seq_Type) return Sequence;
-- convert from a seq_type to a sequence
function Copy (S : Temp_Seq) return Sequence;
-- convert from a temp_seq to a sequence
function Copy (S : Sequence) return Temp_Seq;
-- convert from a sequence to a temp_seq
function Copy (S : Sequence; In_Segment : System.Segment)
return Temp_Seq;
-- convert from a sequence to a temp_seq
procedure Move_Attributes (From : Tree; To : Tree);
procedure Move_Attr_List (From, To : Tree);
procedure Change_Node_Name (T : in out Tree; New_Name : Node_Name);
procedure Change_Node (From : Tree;
To : Tree;
Move_Attrs : Boolean := True;
Detach : Boolean := True);
function Root (Node : Tree) return Tree;
procedure Set_Back_Pointer (Child : Tree; Parent : Tree);
function Invert (L : Seq_Type) return Seq_Type;
-- reverse a seq_type in-place returning head of reversed list
function Duplicate (T : Tree) return Tree;
-- used be tree compaction to copy a tree and its attributes.
end Edit_Utilities;
---------------------------------------------------------------------------
package List_Utilities is
type List_Arity is (Zero, One, Many);
-- operations on DIANA.SEQ_TYPE
function List (N1 : Tree) return Seq_Type;
function List (N1, N2 : Tree) return Seq_Type;
function List (N1, N2, N3 : Tree) return Seq_Type;
function List (N1, N2, N3, N4 : Tree) return Seq_Type;
function List (N1, N2, N3, N4, N5 : Tree) return Seq_Type;
function Length (L : Seq_Type) return Integer;
function Length_Is_One (L : Seq_Type) return Boolean;
function Arity (L : Seq_Type) return List_Arity;
function Is_Member (N : Tree; L : Seq_Type) return Boolean;
-- test if node is a member of a list
function Id_Is_Member
(Id_Node : Tree; Id_List : Seq_Type) return Boolean;
-- test if an id with name of ID_NODE occurs on ID_LIST
function Nconc (L1, L2 : Seq_Type) return Seq_Type;
-- lisp nconc, L2 is attached to LAST (L1), L1 returned
-- is_empty (L1) => return L2;
function Jth (L : Seq_Type; J : Integer) return Tree;
-- returns J'th member of L
-- in J > 0 and LENGTH (L) >= J
function Last (L : Seq_Type) return Seq_Type;
-- returns list part of last member of L
-- is_empty (L) => return make
function Pos (N : Tree; L : Seq_Type) return Integer;
-- position of N within L counting from 0
-- N not in L => return -1
procedure Nconc (L : in out Seq_Type; T : Tree);
-- equivalent to L := NCONC (L, CONS (T, make))
function Get_Seq_Type (List_Element : Tree) return Seq_Type;
--| pre-condition: arity (as_parent (list_element)) = arbitrary.
procedure Insert (Parent : Tree; Node : Tree; Position : Natural);
-- Inserts NODE after the POSITION'th element in the AS_LIST of
-- PARENT. (POSITION = 0) => NODE is new head of list.
-- operations on DIANA.SEQUENCE.
function List (N1 : Tree) return Sequence;
function List (N1, N2 : Tree) return Sequence;
function List (N1, N2, N3 : Tree) return Sequence;
function List (N1, N2, N3, N4 : Tree) return Sequence;
function List (N1, N2, N3, N4, N5 : Tree) return Sequence;
function Length (L : Sequence) return Integer;
function Length_Is_One (L : Sequence) return Boolean;
function Arity (L : Sequence) return List_Arity;
function Is_Member (N : Tree; L : Sequence) return Boolean;
-- test if N occurs on list L
function Id_Is_Member
(Id_Node : Tree; Id_List : Sequence) return Boolean;
-- test if an id with name of ID_NODE occurs on ID_LIST
function Append (L1, L2 : Sequence) return Sequence;
-- lisp append, L1 is copied, L2 is attached to copy which is returned
function Nconc (L1, L2 : Sequence) return Sequence;
-- lisp nconc, L2 is attached to LAST (L1), L1 returned
-- is_empty (L1) => return L2;
function Concat (L1, L2 : Sequence) return Sequence;
-- L1 and L2 are copied then nconc'ed
function Invert (L : Sequence) return Sequence;
-- lisp reverse, makes new copy of list (reverse is a keyword)
function Jth (L : Sequence; J : Integer) return Tree;
-- returns J'th member of L
-- in J > 0 and LENGTH (L) >= J
function Last (L : Sequence) return Sequence;
-- returns list part of last member of L
-- is_empty (L) => return make
function Pos (N : Tree; L : Sequence) return Integer;
-- position of N within L counting from 0
-- N not in L => return -1
procedure Nconc (L : in out Sequence; T : Tree);
-- equivalent to L := NCONC (L, CONS (T, make))
-- operations on DIANA.TEMP_SEQ
function List (N1 : Tree) return Temp_Seq;
function List (N1, N2 : Tree) return Temp_Seq;
function List (N1, N2, N3 : Tree) return Temp_Seq;
function List (N1, N2, N3, N4 : Tree) return Temp_Seq;
function List (N1, N2, N3, N4, N5 : Tree) return Temp_Seq;
function Length (L : Temp_Seq) return Integer;
function Length_Is_One (L : Temp_Seq) return Boolean;
function Arity (L : Temp_Seq) return List_Arity;
function Is_Member (N : Tree; L : Temp_Seq) return Boolean;
-- test if N occurs on list L
function Id_Is_Member
(Id_Node : Tree; Id_List : Temp_Seq) return Boolean;
-- test if an id with name of ID_NODE occurs on ID_LIST
function Append (L1, L2 : Temp_Seq) return Temp_Seq;
function Append (L1 : Sequence; L2 : Temp_Seq) return Temp_Seq;
-- lisp append, L1 is copied, L2 is attached to copy which is returned
function Nconc (L1, L2 : Temp_Seq) return Temp_Seq;
-- lisp nconc, L2 is attached to LAST (L1), L1 returned
-- is_empty (L1) => return L2;
function Concat (L1, L2 : Temp_Seq) return Temp_Seq;
-- L1 and L2 are copied then nconc'ed
function Invert (L : Temp_Seq) return Temp_Seq;
-- lisp reverse, makes new copy of list (reverse is a keyword)
function Jth (L : Temp_Seq; J : Integer) return Tree;
-- returns J'th member of L
-- in J > 0 and LENGTH (L) >= J
function Last (L : Temp_Seq) return Temp_Seq;
-- returns list part of last member of L
-- is_empty (L) => return make
function Pos (N : Tree; L : Temp_Seq) return Integer;
-- position of N within L counting from 0
-- N not in L => return -1
procedure Nconc (L : in out Temp_Seq; T : Tree);
-- equivalent to L := NCONC (L, CONS (T, make))
procedure Insert (Parent : Tree; Node : Tree; After : Diana.Tree);
-- Inserts NODE after AFTER in the AS_LIST of PARENT.
-- is_empty (AFTER) => node is new head of list.
end List_Utilities;
---------------------------------------------------------------------------
package Id_Utilities is
procedure Set_Trace;
procedure Reset_Trace;
function Comp_Unit_Id (Comp_Unit : Tree) return Tree;
-- Returns the Id for a comp unit.
function Unit_Id (Unit : Tree) return Tree;
-- Returns the Id or Designator as appropriate for
-- a given program unit item.
function Get_Id (Decl_Node : Diana.Tree) return Diana.Tree;
-- get the id out of anything that has a single id
function Is_Predefined (Id_Node : Tree) return Boolean;
function Get_Defn (Name : Tree) return Tree;
-- Given a using occurence or selected, returns the defining occurence.
function Enclosing_Declaration (Id : Tree) return Tree;
-- Finds the nearest enclosing declaration (item).
function First_Def_Id
(Item : Tree; Iterate : Boolean := True) return Tree;
function Next_Def_Id (Def_Id : Tree) return Tree;
-- These two functions allow traversal of the entities in a
-- Decl_s or Item_s. Each Def_id will be visited to account for
-- multiple object declarations (x,y:t). This only visits the
-- def_ids for the explicit declarations at the top level.
-- Does not go inside enumaration type declarations, visit
-- implicit operators, visit parameters or record fields, etc.
-- The optional iterate parameter causes first_def_id to
-- search down the Item_s if Item is a use clause or some
-- item which does not have an id.
function First (Id : Diana.Tree) return Diana.Tree;
-- Given a defining occurence, returns the first occurence.
function Flatten (Name : Diana.Tree) return Diana.Sequence;
function Fully_Qualified_Name
(Def_Id : Diana.Tree) return Diana.Sequence;
-- The following functions retrieve all visible entities.
function All_Ids_Of
(Decl_List : Tree; Until_Stub : Symbol_Rep := Null_Text)
return Sequence;
function All_Ids_Of
(Decl_List : Tree; Until_Decl : Tree) return Sequence;
function All_Ids_In_Visible_Part (Package_Spec : Tree) return Sequence;
function All_Ids_In_Private_Part (Package_Spec : Tree) return Sequence;
function All_Ids_In_Task_Spec (Task_Spec : Tree) return Sequence;
function All_Param_Ids_Of (Params : Tree) return Sequence;
function All_Field_Ids_Of (Component_List : Tree) return Sequence;
function All_Label_Ids_Of (Block_Node : Tree) return Sequence;
function All_Named_Stm_Ids_Of (Block_Node : Tree) return Sequence;
function All_Ids_In_Block (Block_Node : Tree; Is_Unit : Boolean := True)
return Sequence;
end Id_Utilities;
---------------------------------------------------------------------------
generic
with procedure Put (S : String);
with procedure New_Line;
with procedure Print_Other_Attrs
(Node : Diana.Tree; Indentation : Integer);
package Symbolic_Io is
procedure Output (List : Diana.Sequence;
With_Attributes : Boolean := True);
procedure Output (Node : Diana.Tree; With_Attributes : Boolean := True);
end Symbolic_Io;
---------------------------------------------------------------------------
package Attr_Names is
function Attr_Address return Symbol_Rep;
function Attr_Base return Symbol_Rep;
function Attr_Size return Symbol_Rep;
function Attr_First return Symbol_Rep;
function Attr_Last return Symbol_Rep;
function Attr_Image return Symbol_Rep;
function Attr_Value return Symbol_Rep;
function Attr_Pos return Symbol_Rep;
function Attr_Val return Symbol_Rep;
function Attr_Pred return Symbol_Rep;
function Attr_Succ return Symbol_Rep;
function Attr_Delta return Symbol_Rep;
function Attr_Machine_Rounds return Symbol_Rep;
function Attr_Digits return Symbol_Rep;
function Attr_Mantissa return Symbol_Rep;
function Attr_Emax return Symbol_Rep;
function Attr_Small return Symbol_Rep;
function Attr_Large return Symbol_Rep;
function Attr_Epsilon return Symbol_Rep;
function Attr_Machine_Radix return Symbol_Rep;
function Attr_Machine_Emax return Symbol_Rep;
function Attr_Machine_Emin return Symbol_Rep;
function Attr_Length return Symbol_Rep;
function Attr_Range return Symbol_Rep;
function Attr_Constrained return Symbol_Rep;
function Attr_Position return Symbol_Rep;
function Attr_First_Bit return Symbol_Rep;
function Attr_Last_Bit return Symbol_Rep;
function Attr_Storage_Size return Symbol_Rep;
function Attr_Terminated return Symbol_Rep;
function Attr_Count return Symbol_Rep;
function Attr_Machine_Mantissa return Symbol_Rep;
function Attr_Machine_Overflows return Symbol_Rep;
function Attr_Aft return Symbol_Rep;
function Attr_Callable return Symbol_Rep;
function Attr_Fore return Symbol_Rep;
function Attr_Safe_Emax return Symbol_Rep;
function Attr_Safe_Large return Symbol_Rep;
function Attr_Safe_Small return Symbol_Rep;
function Attr_Width return Symbol_Rep;
end Attr_Names;
package Pragma_Names is
function Priority return Symbol_Rep;
function Memory_Size return Symbol_Rep;
function Suppress return Symbol_Rep;
function Inline return Symbol_Rep;
function List return Symbol_Rep;
function Pack return Symbol_Rep;
function Storage_Unit return Symbol_Rep;
function Optimize return Symbol_Rep;
function Interface return Symbol_Rep;
function System_Name return Symbol_Rep;
function Controlled return Symbol_Rep;
function Elaborate return Symbol_Rep;
function Page return Symbol_Rep;
function Shared return Symbol_Rep;
end Pragma_Names;
package Operator_Names is
function Abs_Op return Symbol_Rep;
function Plus_Op return Symbol_Rep;
function Minus_Op return Symbol_Rep;
function Times_Op return Symbol_Rep;
function Divide_Op return Symbol_Rep;
function Mod_Op return Symbol_Rep;
function Rem_Op return Symbol_Rep;
function Exp_Op return Symbol_Rep;
function And_Op return Symbol_Rep;
function Or_Op return Symbol_Rep;
function Xor_Op return Symbol_Rep;
function Not_Op return Symbol_Rep;
function Eq_Op return Symbol_Rep;
function Ne_Op return Symbol_Rep;
function Lt_Op return Symbol_Rep;
function Gt_Op return Symbol_Rep;
function Ge_Op return Symbol_Rep;
function Le_Op return Symbol_Rep;
function Concat_Op return Symbol_Rep;
function Operators (Index : Positive) return Symbol_Rep;
end Operator_Names;
package Check_Names is
function Access_Check return Symbol_Rep;
function Discriminant_Check return Symbol_Rep;
function Index_Check return Symbol_Rep;
function Length_Check return Symbol_Rep;
function Range_Check return Symbol_Rep;
function Division_Check return Symbol_Rep;
function Overflow_Check return Symbol_Rep;
function Elaboration_Check return Symbol_Rep;
function Storage_Check return Symbol_Rep;
end Check_Names;
package Exception_Names is
function Constraint_Err return Symbol_Rep;
function Numeric_Err return Symbol_Rep;
function Storage_Err return Symbol_Rep;
function Tasking_Err return Symbol_Rep;
function Program_Err return Symbol_Rep;
end Exception_Names;
---------------------------------------------------------------------------
function Convert (Segment : System.Segment; Offset : System.Bit_Offset)
return Tree;
function Convert (Segment : System.Segment; Offset : System.Bit_Offset)
return Seq_Type;
function Convert (Segment : System.Segment; Offset : System.Bit_Offset)
return Sequence;
function Convert (Segment : System.Segment; Offset : System.Bit_Offset)
return Symbol_Rep;
function Convert (Segment : System.Segment; Offset : System.Bit_Offset)
return Number_Rep;
function Convert (Segment : System.Segment; Offset : System.Bit_Offset)
return Comment;
function Convert (Segment : System.Segment; Offset : System.Bit_Offset)
return Attr_Name;
function Convert (Segment : System.Segment; Offset : System.Bit_Offset)
return Attr_List;
function Convert (Node : Tree) return System.Address;
---------------------------------------------------------------------------
function Node_Size (T : Diana.Tree) return Integer;
function Node_Size (S : Diana.Seq_Type) return Integer;
function Node_Size (S : Diana.Sequence) return Integer;
function Node_Size (S : Diana.Temp_Seq) return Integer;
function Node_Size (L : Attr_List) return Integer;
function Size (S : Diana.Symbol_Rep) return Integer;
function Size (S : Diana.Number_Rep) return Integer;
function Size (S : Diana.Sequence) return Integer;
function Size (S : Diana.Temp_Seq) return Integer;
function Hash (S : Diana.Seq_Type) return Long_Integer;
function Hash (S : Diana.Sequence) return Long_Integer;
function Hash (S : Diana.Temp_Seq) return Long_Integer;
---------------------------------------------------------------------------
-- Operator type
type Operator is
(No_Operation, Boolean_Eq, Boolean_Ne,
Boolean_Lt, Boolean_Le, Boolean_Gt, Boolean_Ge,
Boolean_And, Boolean_Or, Boolean_Xor, Boolean_Not,
Other_Boolean_Eq, Other_Boolean_Ne, Other_Boolean_Lt,
Other_Boolean_Le, Other_Boolean_Gt, Other_Boolean_Ge,
Other_Boolean_And, Other_Boolean_Or,
Other_Boolean_Xor, Other_Boolean_Not,
Integer_Eq, Integer_Ne, Integer_Lt, Integer_Le, Integer_Gt, Integer_Ge,
Integer_Plus, Integer_Neg, Integer_Abs,
Integer_Add, Integer_Sub, Integer_Mul,
Integer_Div, Integer_Mod, Integer_Rem,
Integer_Exp,
Short_Integer_Eq, Short_Integer_Ne, Short_Integer_Lt,
Short_Integer_Le, Short_Integer_Gt, Short_Integer_Ge,
Short_Integer_Plus, Short_Integer_Neg, Short_Integer_Abs,
Short_Integer_Add, Short_Integer_Sub, Short_Integer_Mul,
Short_Integer_Div, Short_Integer_Mod, Short_Integer_Rem,
Short_Integer_Exp,
Short_Short_Integer_Eq, Short_Short_Integer_Ne, Short_Short_Integer_Lt,
Short_Short_Integer_Le, Short_Short_Integer_Gt, Short_Short_Integer_Ge,
Short_Short_Integer_Plus,
Short_Short_Integer_Neg, Short_Short_Integer_Abs,
Short_Short_Integer_Add, Short_Short_Integer_Sub,
Short_Short_Integer_Mul, Short_Short_Integer_Div,
Short_Short_Integer_Mod, Short_Short_Integer_Rem,
Short_Short_Integer_Exp,
Long_Integer_Eq, Long_Integer_Ne, Long_Integer_Lt,
Long_Integer_Le, Long_Integer_Gt, Long_Integer_Ge,
Long_Integer_Plus, Long_Integer_Neg, Long_Integer_Abs,
Long_Integer_Add, Long_Integer_Sub, Long_Integer_Mul,
Long_Integer_Div, Long_Integer_Mod, Long_Integer_Rem,
Long_Integer_Exp,
Long_Long_Integer_Eq, Long_Long_Integer_Ne, Long_Long_Integer_Lt,
Long_Long_Integer_Le, Long_Long_Integer_Gt, Long_Long_Integer_Ge,
Long_Long_Integer_Plus, Long_Long_Integer_Neg, Long_Long_Integer_Abs,
Long_Long_Integer_Add, Long_Long_Integer_Sub, Long_Long_Integer_Mul,
Long_Long_Integer_Div, Long_Long_Integer_Mod, Long_Long_Integer_Rem,
Long_Long_Integer_Exp,
Formal_Integer_Eq, Formal_Integer_Ne, Formal_Integer_Lt,
Formal_Integer_Le, Formal_Integer_Gt, Formal_Integer_Ge,
Formal_Integer_Plus, Formal_Integer_Neg, Formal_Integer_Abs,
Formal_Integer_Add, Formal_Integer_Sub, Formal_Integer_Mul,
Formal_Integer_Div, Formal_Integer_Mod, Formal_Integer_Rem,
Formal_Integer_Exp,
Universal_Integer_Eq, Universal_Integer_Ne, Universal_Integer_Lt,
Universal_Integer_Le, Universal_Integer_Gt, Universal_Integer_Ge,
Universal_Integer_Plus, Universal_Integer_Neg, Universal_Integer_Abs,
Universal_Integer_Add, Universal_Integer_Sub, Universal_Integer_Mul,
Universal_Integer_Div, Universal_Integer_Mod, Universal_Integer_Rem,
Universal_Integer_Exp,
Other_Integer_Eq, Other_Integer_Ne, Other_Integer_Lt,
Other_Integer_Le, Other_Integer_Gt, Other_Integer_Ge,
Other_Integer_Plus, Other_Integer_Neg, Other_Integer_Abs,
Other_Integer_Add, Other_Integer_Sub, Other_Integer_Mul,
Other_Integer_Div, Other_Integer_Mod, Other_Integer_Rem,
Other_Integer_Exp,
Float_Eq, Float_Ne, Float_Lt, Float_Le, Float_Gt, Float_Ge,
Float_Plus, Float_Neg, Float_Abs,
Float_Add, Float_Sub, Float_Mul, Float_Div,
Float_Exp,
Short_Float_Eq, Short_Float_Ne, Short_Float_Lt,
Short_Float_Le, Short_Float_Gt, Short_Float_Ge,
Short_Float_Plus, Short_Float_Neg, Short_Float_Abs,
Short_Float_Add, Short_Float_Sub, Short_Float_Mul, Short_Float_Div,
Short_Float_Exp,
Short_Short_Float_Eq, Short_Short_Float_Ne, Short_Short_Float_Lt,
Short_Short_Float_Le, Short_Short_Float_Gt, Short_Short_Float_Ge,
Short_Short_Float_Plus, Short_Short_Float_Neg, Short_Short_Float_Abs,
Short_Short_Float_Add, Short_Short_Float_Sub,
Short_Short_Float_Mul, Short_Short_Float_Div,
Short_Short_Float_Exp,
Long_Float_Eq, Long_Float_Ne, Long_Float_Lt,
Long_Float_Le, Long_Float_Gt, Long_Float_Ge,
Long_Float_Plus, Long_Float_Neg, Long_Float_Abs,
Long_Float_Add, Long_Float_Sub, Long_Float_Mul, Long_Float_Div,
Long_Float_Exp,
Long_Long_Float_Eq, Long_Long_Float_Ne, Long_Long_Float_Lt,
Long_Long_Float_Le, Long_Long_Float_Gt, Long_Long_Float_Ge,
Long_Long_Float_Plus, Long_Long_Float_Neg, Long_Long_Float_Abs,
Long_Long_Float_Add, Long_Long_Float_Sub,
Long_Long_Float_Mul, Long_Long_Float_Div,
Long_Long_Float_Exp,
Formal_Float_Eq, Formal_Float_Ne, Formal_Float_Lt,
Formal_Float_Le, Formal_Float_Gt, Formal_Float_Ge,
Formal_Float_Plus, Formal_Float_Neg, Formal_Float_Abs,
Formal_Float_Add, Formal_Float_Sub, Formal_Float_Mul, Formal_Float_Div,
Formal_Float_Exp,
Universal_Real_Eq, Universal_Real_Ne, Universal_Real_Lt,
Universal_Real_Le, Universal_Real_Gt, Universal_Real_Ge,
Universal_Real_Plus, Universal_Real_Neg, Universal_Real_Abs,
Universal_Real_Add, Universal_Real_Sub,
Universal_Real_Mul, Universal_Real_Div,
Universal_Real_Exp,
Universal_Integer_Real_Mul, Universal_Real_Integer_Mul,
Universal_Real_Integer_Div,
Universal_Fixed_Mul, Universal_Fixed_Div,
Duration_Eq, Duration_Ne, Duration_Lt,
Duration_Le, Duration_Gt, Duration_Ge,
Duration_Plus, Duration_Neg, Duration_Abs,
Duration_Add, Duration_Sub, Duration_Integer_Mul,
Integer_Duration_Mul, Duration_Integer_Div,
Formal_Fixed_Eq, Formal_Fixed_Ne, Formal_Fixed_Lt,
Formal_Fixed_Le, Formal_Fixed_Gt, Formal_Fixed_Ge,
Formal_Fixed_Plus, Formal_Fixed_Neg, Formal_Fixed_Abs,
Formal_Fixed_Add, Formal_Fixed_Sub, Formal_Fixed_Integer_Mul,
Integer_Formal_Fixed_Mul, Formal_Fixed_Integer_Div,
Other_Fixed_Eq, Other_Fixed_Ne, Other_Fixed_Lt,
Other_Fixed_Le, Other_Fixed_Gt, Other_Fixed_Ge,
Other_Fixed_Plus, Other_Fixed_Neg, Other_Fixed_Abs,
Other_Fixed_Add, Other_Fixed_Sub, Other_Fixed_Integer_Mul,
Integer_Other_Fixed_Mul, Other_Fixed_Integer_Div,
Character_Eq, Character_Ne, Character_Lt,
Character_Le, Character_Gt, Character_Ge,
Enumeration_Eq, Enumeration_Ne, Enumeration_Lt,
Enumeration_Le, Enumeration_Gt, Enumeration_Ge,
Formal_Discrete_Eq, Formal_Discrete_Ne, Formal_Discrete_Lt,
Formal_Discrete_Le, Formal_Discrete_Gt, Formal_Discrete_Ge,
String_Eq, String_Ne, String_Lt, String_Le, String_Gt, String_Ge,
String_String_Cat, String_Character_Cat,
Character_String_Cat, Character_Character_Cat,
One_Dim_Array_Eq, One_Dim_Array_Ne,
One_Dim_Discrete_Array_Lt, One_Dim_Discrete_Array_Le,
One_Dim_Discrete_Array_Gt, One_Dim_Discrete_Array_Ge,
One_Dim_Boolean_Array_Not, One_Dim_Boolean_Array_And,
One_Dim_Boolean_Array_Or, One_Dim_Boolean_Array_Xor,
One_Dim_Array_Array_Cat, One_Dim_Array_Element_Cat,
One_Dim_Element_Array_Cat, One_Dim_Element_Element_Cat,
Multi_Dim_Array_Eq, Multi_Dim_Array_Ne,
One_Dim_Formal_Array_Eq, One_Dim_Formal_Array_Ne,
One_Dim_Discrete_Formal_Array_Lt, One_Dim_Discrete_Formal_Array_Le,
One_Dim_Discrete_Formal_Array_Gt, One_Dim_Discrete_Formal_Array_Ge,
One_Dim_Boolean_Formal_Array_Not, One_Dim_Boolean_Formal_Array_And,
One_Dim_Boolean_Formal_Array_Or, One_Dim_Boolean_Formal_Array_Xor,
One_Dim_Formal_Array_Array_Cat, One_Dim_Formal_Array_Element_Cat,
One_Dim_Formal_Element_Array_Cat, One_Dim_Formal_Element_Element_Cat,
Multi_Dim_Formal_Array_Eq, Multi_Dim_Formal_Array_Ne,
Record_Eq, Record_Ne,
Access_Eq, Access_Ne,
Formal_Access_Eq, Formal_Access_Ne,
Private_Eq, Private_Ne,
Formal_Private_Eq, Formal_Private_Ne);
procedure Sm_Operator (T : Tree; V : Operator);
function Sm_Operator (T : Tree) return Operator;
procedure Sm_Operator_Value (T : Tree; V : Operator);
function Sm_Operator_Value (T : Tree) return Operator;
---------------------------------------------------------------------------
-- Line Count attribute for pretty printer.
type Line_Count is new Integer range 0 .. 2 ** 24 - 1;
function Lx_Line_Count (T : Tree) return Line_Count;
procedure Lx_Line_Count (T : Tree; V : Line_Count);
-- Predicates to facilitate efficient traversal of structural
-- lists.
function Is_In_List (T : Diana.Tree) return Boolean;
-- returns true iff T is a member of a structural list, i.e.
-- iff T = Diana.Head (S) for some seq_type value S.
function Is_At_Lists_End (T : Diana.Tree) return Boolean;
---------------------------------------------------------------------------
package Id_Table_Attrs is
function Has_Sm_Seqnum (Id : Diana.Tree) return Boolean;
procedure Sm_Seqnum (Id : Diana.Tree; Seqnum : Integer);
function Sm_Seqnum (Id : Diana.Tree) return Integer;
procedure Sm_Id_Table (Decl_Regn : Diana.Tree; Value : Id_Table.Id_Map);
function Sm_Id_Table (Decl_Regn : Diana.Tree) return Id_Table.Id_Map;
function Has_Sm_Id_Table (Decl_Regn : Diana.Tree) return Boolean;
end Id_Table_Attrs;
---------------------------------------------------------------------------
type Decl_Number is range 0 .. 4095;
type Decl_Number_Mask_Array is array (Decl_Number) of Boolean;
type Decl_Number_Mask is access Decl_Number_Mask_Array;
pragma Segmented_Heap (Decl_Number_Mask);
---------------------------------------------------------------------------
type Tree_Vector is array (Positive range <>) of Diana.Tree;
function Is_Comment (Node : Diana.Tree) return Boolean;
type Declaration_Number is new Natural;
type Declaration_Number_Mask_Array is
array (Declaration_Number range <>) of Boolean;
type Declaration_Number_Mask is access Declaration_Number_Mask_Array;
pragma Segmented_Heap (Declaration_Number_Mask);
function Has_Lx_Line_Count (T : Diana.Tree) return Boolean;
end Diana;
pragma Cache_Register (Diana, 11);with Diana;
package Diana_Renames is
function "=" (X, Y : Diana.Tree) return Boolean renames Diana."=";
function "=" (X, Y : Diana.Seq_Type) return Boolean renames Diana."=";
function "=" (X, Y : Diana.Sequence) return Boolean renames Diana."=";
function "=" (X, Y : Diana.Node_Name) return Boolean renames Diana."=";
function "=" (X, Y : Diana.Value_Kind) return Boolean renames Diana."=";
pragma Subsystem (Ada_Management);
pragma Module_Name (4, 1104);
end Diana_Renames;with Action;
with Calendar;
with Default;
with Diana;
with Error_Messages;
with Job_Segment;
with Machine;
with System;
package Directory is
pragma Subsystem (Directory, Private_Part => Closed);
pragma Module_Name (4, 1701);
-- VISIBLE PART ORGANIZATION
-- 1. Introductory comments and types. Defines the key types
-- Directory.Declaration (declarations in the directory system),
-- Directory.Object (Managed Objects in the directory system),
-- Directory.Version (Versions of managed directory objects), etc.
-- 2. Package Naming. Provides facilities for establishing a context
-- for name resolution and facilities for resolving string names.
-- 3. Package Ada. Defines an Ada Unit as a kind of Directory.Object.
-- Provides type-specific operations for constructing and manipulating
-- Ada Units. Included here because of the initimate relation between
-- Ada Units and the Directory (i.e., Ada Units ARE the directory
-- structure).
-- 4. Package Traversal. Operations for traversing the directory
-- structure (which extends through all Ada units in the system).
-- 5. Package Declaration_Operations. Provides the basic operations
-- for installing, coding, and withdrawing declarations.
-- 6. Package Object_Operations. Standard Directory operations for
-- Creating, Freezing, Destroying and Copying managed objects in the
-- Directory. Includes a special form of create to facilitate
-- construction of packages (serving as subdirectories).
-- 7. Package Policy.
-- 8. Package Control_Point. Defines a control point as a distinguished
-- point (package or library) in the package directory system. A control
-- point specificies the disk volume for storing its contents and the
-- policies which will apply to its contents.
-- 9. Package Statistics. Queries about Directory Objects.
-- This package is the main interface to the directory subsystem.
-- The Directory system provides the structure for storing, managing
-- and naming objects. The directory provides the following mappings,
-- which should help clarify the relations between types.
-- Directory:
-- String <=> Directory.Declaration
-- Directory.Declaration <=> Directory.Object
-- Directory.Object X Directory.Version_Name => Directory.Version
-- Directory.Declaration == Diana.Tree
-- Directory.Version == Standard.Object.Id
-- Object Management System:
-- Object.Id => Data
-- The package directory consists of declarations represented
-- with Diana (Directory.Declaration). Some declarations correspond
-- to managed Directory Objects (Directory.Object). The declaration
-- for a Directory Object is either a constant declaration with
-- the type (derived from) Directory.Object, or a program unit stub.
-- Allowing only constants prevents garbage formation and simpifies
-- some control issues. The type of the managed object defines its
-- class (Directory.Class). Program units belong to the class Ada.
-- The class reflects which object manager manages objects of that
-- type, as well as reflecting the type. A Directory Object has one
-- or more versions (Directory.Version == Standard.Object.Id)
-- which can be selected by using the appropriate version name
-- (Directory.Version_Name).
-- Managed objects in the directory are of type Directory.Object.
-- Some complexity is introduced by the fact that a program unit
-- has a runtime value which is an elaborated subprogram variable
-- or package variable (or whatever) and also has a source value
-- which is a managed value that provides access to the (Diana)
-- program representation. When applied to program units,
-- the operations defined here apply only to the source value.
-- Most operations which take an object as a parameter also take
-- a version name. If the version name is defaulted, then the
-- default version is computed (consistent with applicable policies).
-- Ada.Unit and Polymorphic_IO.File (and others) are ultimately
-- of type Directory.Object and provide type specific operations.
-- The general paradigm is that type independent operations
-- (traversal, create, copy, destroy, etc.) are provided in
-- directory, while type specific operations are provided by the
-- packages (Directory.Ada, Polymorphic_io, etc.) which introduce
-- specific managed types.
-- No exceptions are propagated from this package, except those
-- associated with type specific operations
Default_Wait : constant Duration := 0.5;
type Error_Status is --
(Successful, -- No problems encountered.
Lock_Error, -- Some synchronization error occurred,
-- usually failure to acquire access to some
-- object within the specified maximum delay
Semantic_Error, -- An operation requiring (Ada) semantic
-- consistency discovered semantic errors.
Code_Generation_Error, -- An error was detected during cg.
Obsolescence_Error, -- A change was prevented because it
-- obsolesced installed declarations.
Bad_Tree_Parameter, -- An actual tree parameter failed to meet
-- the requirements of the formal subtype.
Illegal_Operation, -- The attempted operation is not legal
-- when applied to the given parameters.
Consistency_Error, -- The operation is inconsistent with the
-- current state of the universe.
Version_Error, -- The specified version does not exist.
Name_Error, -- Errors occured resolving a name.
Access_Error, -- The operation violates access control
-- policies.
Policy_Error, -- The operation violates some other policy
-- that applies at this point.
Bad_Action, -- The Action.Id provided is illegal.
Class_Error, -- The class of the object passed to the
-- operation is incompatible with op
-- either because the op expects a
-- particular class, or because the
-- op is a type independent op which
-- is not supported for the given class.
Other_Error -- When all else fails ...
);
subtype Declaration is Diana.Tree;
-- A declaration (Diana class Item). Either the Id node or the
-- actual Item node is accepted as representing the declaration.
-- The Id is "preferred", and is returned by operations here.
type Object is private;
-- Managed objects in the directory are of the type Directory.Object.
function Nil return Directory.Object;
function Is_Nil (The_Object : Directory.Object) return Boolean;
function Hash (The_Object : Directory.Object) return Integer;
function Unique (The_Object : Directory.Object) return Long_Integer;
type Version is private;
-- A Directory.Object can be viewed as a set of managed values (of
-- type Directory.Version) where each value represents a different
-- version of the object. Managed values are built upon the more
-- primitive Object.Id type provided by the Object Management System.
function Nil return Version;
function Is_Nil (The_Version : Version) return Boolean;
function Hash (The_Version : Version) return Integer;
function Unique (The_Version : Version) return Long_Integer;
subtype Version_Name is Integer;
subtype Real_Version_Name is Version_Name range 1 .. Version_Name'Last;
-- Each Version has a name, which may be used to select a particular
-- Version from an Object.
Default_Version : constant Version_Name := 0;
Max_Version : constant Version_Name := -1;
Min_Version : constant Version_Name := -2;
Nil_Version : constant Version_Name := -3;
New_Version : constant Version_Name := -4;
All_Versions : constant Version_Name := -5;
-- Reserved version names.
function Get_Version_Name (The_Version : Version) return Version_Name;
-- Returns the Real_Version_Name for a version, or Nil_Version if an error.
function Version_Name_Image (The_Name : Version_Name) return String;
-- Returns a name of the form Vnn or a descriptive string for reserved
-- names.
type Class is private;
-- The class of an object identifies which manager is responsible for
-- the objects, and also identifies the user visible type (derived from
-- Directory.Object), providing the user view of that class of object.
function Nil return Class;
function Is_Nil (The_Id : Class) return Boolean;
function Hash (The_Id : Class) return Integer;
function Get_Class (For_Object : Directory.Object) return Class;
function Get_Class (The_Type : Declaration) return Class;
function Class_Image (The_Class : Class) return String;
function Class_Value (Image : String) return Class;
type Subclass is new Natural;
-- Subclasses distinguish different 'flavors' of objects of a
-- given class.
function Nil return Subclass;
function Is_Nil (The_Id : Subclass) return Boolean;
function Unique (The_Id : Subclass) return Integer;
function Subclass_Image (The_Subclass : Subclass) return String;
function Subclass_Value (Image : String) return Subclass;
function Short_Subclass_Image (The_Subclass : Subclass) return String;
function Get_Subclass (The_Object : Directory.Object) return Subclass;
function Get_Class (The_Subclass : Subclass) return Class;
type Target_Key is private;
-- Basically a descriptor of target semanticist/code_generator/etc.
function Nil return Target_Key;
function Is_Nil (K : Target_Key) return Boolean;
subtype Switches_Type is Version;
-- Switches are used to provide user control over optional functionality.
-- Switches are represented by a special file type, represented by the
-- Version of the directory object containing the switch values.
Default_Position : constant Natural := Natural'Last;
-- Specifies the end of the list.
Default_Retention_Count : constant := -1;
-- Use existing count or inherit one from the parent object.
type Package_Part is (Visible_Part, Body_Part, Both_Parts);
type Change_Limit is
(Object_Only, -- Given object may be altered, set is ignored.
Same_Objects, -- Objects in the set may be altered.
Same_Libraries, -- Objects in libraries in the set may be altered.
Same_Worlds, -- Objects in worlds in the set may be altered.
Any_Object -- Anything may be changed, set is ignored
);
-- A Change_Limit, along with an Object_Set.Set, will determine which
-- objects may be implicitly modified (usually by the cg_controller)
-- in order to perform the requested operation.
----------------------------------------------------------------------
package Object_Set is
type Set is private;
Nil : constant Set;
procedure Initialize (The_Set : out Set; Storage : System.Segment);
function Cardinality (The_Set : Set) return Natural;
function Is_Empty (The_Set : Set) return Boolean;
procedure Make_Empty (The_Set : Set);
procedure Copy (Target : Set; Source : Set);
function Is_Member (The_Set : Set; The_Object : Object) return Boolean;
procedure Add (The_Set : Set; The_Object : Object);
procedure Delete (The_Set : Set; The_Object : Object);
type Iterator is private;
procedure Init (Iter : out Iterator;
The_Set : Set;
Storage : System.Segment);
procedure Next (Iter : in out Iterator);
function Value (Iter : Iterator) return Object;
function Done (Iter : Iterator) return Boolean;
end Object_Set;
----------------------------------------------------------------------
package Naming is
-- Provides mechanisms for resolving names and for
-- establishing a context for name resolution.
subtype Name is String;
-- Lexically and syntactically an Ada Name.
subtype Simple_Name is String;
-- A simple ada name. Basically, an identifier or operator.
type Name_Status is --
(Successful, -- The name was resolved.
Bad_Context, -- The context was not a valid context for
-- name resolution.
Ill_Formed_Name, -- The name was not well formed lexically or
-- syntacticly.
Undefined, -- The name could not be found in the given
-- context.
Lock_Error, -- Indirect file is locked.
Access_Error, -- Access to objects denied.
Ambiguous, -- Because of overloading or wildcards, the
-- name resolved to more than one entity.
No_Selection, -- Nothing is selected.
Cursor_Not_In_Selection, Selections_Not_Supported,
Class_Error, No_Declaration, No_Object, No_Editor,
Unsuccessful -- resolution failed for some other reason.
);
function Diagnosis
(Status : Name_Status; Name : Naming.Name) return String;
-- Returns a string form of the status, suitable for error messages.
subtype Context is Diana.Tree;
-- Allows specification of a semantic context as an insertion point
-- or as an Item (in which case the context is after the item),
-- or as a block, decl_s or item_s (in which case the context
-- is at the end of the corresponding declarative part) or a
-- comp_unit corresponding to a package (in which case the
-- context is at the end of the visible part or the body block).
-- The context must be installed. Name resolution context will
-- start as the library enclosing the current context. The string
-- "[]" will force it to be the context given here.
procedure Get_Context (The_Context : out Naming.Context;
The_Version : Version;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Get_Context (The_Context : out Naming.Context;
The_Unit : Directory.Object;
Status : out Error_Status;
Version : Version_Name := Default_Version;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- The_Version must be an installed ada unit.
procedure Set_Default_Context
(The_Context : Naming.Context;
Status : out Error_Status;
For_Job : Default.Process_Id := Default.Process);
procedure Set_Default_Context
(The_Context : Version;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait;
For_Job : Default.Process_Id := Default.Process);
-- Establishes the default naming context for a given job.
-- The second form sets the context using the comp_unit of the
-- given ada unit. The unit must be an installed ada unit.
function Default_Context
(For_Job : Default.Process_Id := Default.Process)
return Naming.Context;
-- Returns the default name resolution context for this job.
-- If no context has been specified, returns the Universe_Context.
function Universe_Context return Naming.Context;
-- Return the context representing the root of the universe.
type Iterator is private;
-- Generalized Wildcard iterator
function Nil return Iterator;
function Is_Nil (Iter : Iterator) return Boolean;
procedure Resolve (Iter : out Iterator;
Source : Naming.Name;
Status : out Name_Status;
Environment : Naming.Context := Default_Context;
Deleted_Ok : Boolean := False;
Objects_Only : Boolean := True;
Heap : System.Segment := Job_Segment.Get;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Resolves (ambiguous) Source name in the given environment. In
-- Delta, the other form of ambiguous resolve will be withdrawn.
-- This is only mechanism provided for iterating at the version
-- level or for deleted versions. Also facilitates derivation of
-- target name (with substitution characters) from corresponding
-- source name (with wildcards) If Deleted_Ok is true, deleted (but
-- not expunged) objects will be included in the iteration.
-- (Deleted objects must have at least one extant version, but may
-- have no declaration.) If Objects_Only is true, only (separate)
-- objects that match the source name will be included; when false,
-- Ada declarations will be included even if no separate object is
-- associated with them. Resolution is more efficient if
-- Objects_Only is true. (Deleted_Ok implies Objects_Only)
procedure Reset (Iter : in out Iterator);
-- Restore the iterator to its initial (post-Resolve) state.
procedure Next (Iter : in out Iterator);
function Done (Iter : Iterator) return Boolean;
function Get_Class (Iter : Iterator) return Directory.Class;
function Get_Subclass (Iter : Iterator) return Directory.Subclass;
procedure Get_Declaration (Iter : Iterator;
The_Decl : out Directory.Declaration;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Get_Object (Iter : Iterator;
The_Object : out Directory.Object;
Status : out Error_Status);
procedure Get_Version (Iter : Iterator;
The_Version : out Directory.Version;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Get_Root (Iter : Iterator;
The_Root : out Diana.Tree;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
function Source_Name (Iter : Iterator) return Name;
function Target_Name (Iter : Iterator; Target : Name) return Name;
-- Replaces the substitution characters in the given Target name
-- with the appropriate values derived from the current entity of
-- the iteration.
function Status (Iter : Iterator) return Name_Status;
-- Returns the status of the last operation performed on the
-- iteration variable.
function Has_Substitution_Characters (Target : Name) return Boolean;
function Target_Name (The_Decl : Directory.Declaration;
Source : Name;
Target : Name) return Name;
function Target_Name (The_Object : Directory.Object;
Source : Name;
Target : Name) return Name;
function Target_Name (The_Version : Directory.Version;
Source : Name;
Target : Name) return Name;
-- Given an entity and a source name (with wild cards) that
-- matches the name of the entity, returns a target string in which
-- substitution characters have been replaced by the matching
-- portions of the entity's name as indicated by the source name
-- pattern.
procedure Resolve (Name : Naming.Name;
The_Object : out Directory.Object;
Status : out Name_Status;
Environment : Naming.Context := Default_Context;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Resolve (Name : Naming.Name;
Environment : Naming.Context;
Def_Id : out Directory.Declaration;
Status : out Name_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Resolve (Name : Naming.Name;
The_Version : out Directory.Version;
Status : out Name_Status;
Environment : Naming.Context := Default_Context;
Deleted_Ok : Boolean := False;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Resolve name to specified version. If Deleted_Ok is true, a version
-- will be returned if it exists even if it has been deleted.
type Special_String_Type is --
(Not_Special, -- string is not of the form "<mumble>"
Unknown_String, -- Unrecognized string of the right form.
Image_String, -- "<IMAGE>", the current window or selection
Cursor_String, -- "<CURSOR>", the object under the cursor
Region_String, -- "<REGION>", the current selected object
Selection_String, -- "<SELECTION>", selected and the cursor in selection.
Text_String, -- "<TEXT>", the text of the current selection
Activity_String, -- "<ACTIVITY>", the current activity or selection.
Switch_String -- "<SWITCH>", the current switch file or selection.
);
-- Various special strings of the form "<mumble>" can be used to
-- resolve to items on the screen. These special strings can be
-- imbedded in names passed to the resolution procedures. Any
-- unique prefix of "mumble" may be used (e.g., "<mum>").
function String_Type (The_Name : String) return Special_String_Type;
-- Classify a special_string by returning its type.
function Is_Well_Formed (A_Name : Name) return Boolean;
-- Tests whether a name is lexically and syntactically valid.
function Get_Prefix (The_Name : Name) return Name;
-- Removes the last segment from a selected name and returns
-- the prefix.
-- Prefix ("A.B.C") => "A.B"
-- Prefix ("A") => ""
function Get_Simple_Name (The_Name : Name) return Simple_Name;
-- Returns only the last segment of a selected name.
-- Simple_name ("A.B.C") => "C"
-- Simple_name ("A") => "A"
function Get_Head (The_Name : Name) return Simple_Name;
-- Returns only the first segment of a selected name.
-- Head ("A.B.C") => "A"
-- Head ("A") => "A"
function Get_Tail (The_Name : Name) return Name;
-- Removes the first segment from a selected name and returns the tail.
-- Tail ("A.B.C") => "B.C"
-- Tail ("A") => ""
function Expand (The_Name : Name;
Environment : Naming.Context := Default_Context;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait) return Name;
-- Expands any prefix characters in the name appropriately.
function Get_Full_Name (Entity : Directory.Declaration) return Name;
function Get_Full_Name (Entity : Directory.Object) return Name;
function Get_Full_Name (Entity : Directory.Version) return Name;
-- Computes the fully qualified Ada name for the entity.
function Get_Simple_Name (Entity : Declaration) return Simple_Name;
function Get_Simple_Name (Entity : Directory.Object) return Simple_Name;
function Get_Simple_Name
(Entity : Directory.Version) return Simple_Name;
-- Computes the simple Ada name for the entity.
function Unique_Full_Name (Entity : Declaration) return Name;
function Unique_Full_Name (Entity : Directory.Object) return Name;
function Unique_Full_Name (Entity : Directory.Version) return Name;
-- Get_Full_Name with 'body, 'n(), and 'v() attributes as needed.
function Unique_Simple_Name (Entity : Declaration) return Simple_Name;
function Unique_Simple_Name
(Entity : Directory.Object) return Simple_Name;
function Unique_Simple_Name
(Entity : Directory.Version) return Simple_Name;
-- Get_Simple_Name with 'body, 'n(), and 'v() attributes as needed.
function Get_Ada_Name (Entity : Declaration) return Name;
function Get_Ada_Name (Entity : Directory.Object) return Name;
function Get_Ada_Name (Entity : Directory.Version) return Name;
-- Similar to Get_Full_Name, but stops at libraries.
procedure Nickname (Def_Id : Directory.Declaration; Name : Simple_Name);
-- Overloaded Ada declarations can be given unique string names by
-- associating a unique nickname with each overloaded Def_Id. The given
-- Def_Id node must be open for update/overwrite to apply the nickname.
-- The Name string is either the null string or in the form of an Ada
-- simple name. The user-specified nickname must be in the form of an
-- Ada simple name. The user-defined nickname can be changed at any
-- time by assigning it a new name. A null string cancels any
-- user-defined nickname associated with the Id.
function Nickname (Def_Id : Directory.Declaration) return String;
-- Returns the user-defined nickname associated with Def_Id, if one has
-- been specified; returns the system-defined nickname otherwise.
function System_Nickname (Def_Id : Directory.Declaration) return String;
-- Returns the system-assigned nickname for the given Def_Id, whether
-- or not a user-defined nickname has been assigned. The
-- system-assigned nickname is the image of the ordinal position
-- (1-origin) of the def_id among its namesakes in its declarative
-- region.
function Is_Overloaded (Def_Id : Directory.Declaration) return Boolean;
-- returns true if the given Def_Id is an overloaded Ada declaration.
function Unique_Simple_Name (The_Name : Name) return Name;
-- Returns the last segment of a name (including attributes);
-- Get_Simple_Name strips the attributes
function Get_Class (The_Name : Name) return String;
-- Extracts the class name attribute from the last segment of
-- The_Name. The name of the class is returned if found. The result
-- is the null string, otherwise.
function Get_Version (The_Name : Name) return String;
-- Extracts the version name attribute from the last segment of
-- The_Name.
function Ineffable_Name (Entity : Directory.Version) return String;
-- Return as descriptive a name as possible for an object which
-- may or may not be part of the normal universe. The Resolve
-- procedures will not necessarily understand theses names.
-- A network object name consists of "!!", followed by a host
-- name, followed by either "." or "!", followed by the name
-- of an object within that host. A host name can be resolved
-- to a network name and host address using package Transport_Name.
function Is_Network_Name (The_Name : Name) return Boolean;
-- Return true iff the The_Name is a syntactically correct
-- network object name. The host name need not be defined.
function Network_Name_To_Host (The_Name : Name) return Name;
-- If not Is_Network_Name (The_Name) then return "".
-- Otherwise, return the host name part of the network object name,
-- without the leading "!!" or trailing punctuation "!" or ".".
-- The returned name is not neccessarily defined.
function Network_Name_To_Rest (The_Name : Name) return Name;
-- If not Is_Network_Name (The_Name) then return The_Name.
-- Otherwise, return the object name part of the network object name,
-- beginning with "!" (even if the original punctuation was ".").
-- The returned name does not neccessarily denote an extant object.
function Extended_Diagnosis
(Status : Name_Status;
Source : Naming.Name;
Environment : Naming.Context := Default_Context;
Deleted_Ok : Boolean := False;
Objects_Only : Boolean := True;
Heap : System.Segment := Job_Segment.Get;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait) return String;
-- Generates a subordinate clause, which could follow a conjunction
-- such as "because", that explains the reason the status was returned
-- by Resolve.
procedure Release (Iter : in out Iterator);
-- Release storage occupied by iterator. Released space will be
-- reused by subsequent Resolutions by the calling job. After
-- the call to Release, the iterator variable is unusable except as
-- an argument to Resolve.
function Get_Order (Iter : Iterator) return Directory.Subclass;
-- The Order (see below) of the default version of the object
-- referenced by the iterator expressed as a subclass.
end Naming;
----------------------------------------------------------------------
type Unit_Implementation is private;
type Conversion_Key_Implementation is private;
-- Private types required by Ada visibility and type completion rules.
-- No operations are provided on this type.
package Ada is
-- This package defines an Ada.Unit as a new Directory.Object.
-- This type represents the source of any separate Ada unit.
-- Type (class) specific operations on Ada Units are provided here.
-- See Ada_Manager to implement most operations.
subtype Stub is Diana.Tree;
-- A stub declaration or a nonterminal (insertion point).
subtype Unit is Unit_Implementation;
-- The managed object corresponding to the source for a separate
-- Ada unit. The corresponding declaration in the directory is
-- either a program unit stub or a library variable declaration.
function Hash (The_Unit : Ada.Unit) return Integer;
function Unique (The_Unit : Ada.Unit) return Long_Integer;
function Get_Unit (The_Object : Directory.Object) return Ada.Unit;
function Get_Object (The_Unit : Ada.Unit) return Directory.Object;
-- Conversions between Object and Unit.
subtype Version is Directory.Version;
-- The values (Versions) of a Unit; corresponds to Ada_Manager.Id.
function Get_Class return Directory.Class;
-- Returns the Class of Ada Units (Ada_manager.Class).
function Get_Subclass (Root : Diana.Tree) return Directory.Subclass;
-- Returns the subclass of the ada unit passed.
subtype Root is Diana.Tree;
subtype Roots is Diana.Temp_Seq;
-- The root node of the value of an Ada Unit, and a sequence of such.
subtype Any_Node is Diana.Tree;
-- Indicates a situation where any node within an Ada unit
-- may be used as a representative of the entire unit.
procedure Set_Root (New_Root : Root;
Status : out Error_Status;
Action_Id : Action.Id);
-- Establishes New_Root as the root of the containing Ada.Version.
-- The New_Root must not be void, and must be in a source unit,
-- else Illegal_operation. The unit must be open for update by
-- Action_Id, or open for update and Action_Id = Action.Null_Id;
procedure Get_Root (Node : Any_Node;
Result : out Root;
Status : out Error_Status);
-- Returns the Root of the unit represented by the Node.
procedure Get_Version (Node : Any_Node;
Result : out Ada.Version;
Status : out Error_Status);
-- Returns the Version containing the Node.
procedure Get_Unit (Node : Any_Node;
Result : out Ada.Unit;
Status : out Error_Status);
-- Returns the Unit containing the Node.
procedure Get_Parent (The_Unit : Ada.Version;
Result : out Ada.Version;
Status : out Error_Status;
Version : Version_Name := Default_Version;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Returns the unit (version) containing the stub declaration
-- for The_Unit.
type Cg_Phase is range 0 .. 15;
procedure Get_Phase (The_Unit : Ada.Unit;
Result : out Cg_Phase;
Status : out Error_Status;
Version : Version_Name := Default_Version;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Set_Phase (The_Unit : Ada.Unit;
Phase : Cg_Phase;
Status : out Error_Status;
Version : Version_Name := Default_Version;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
subtype Conversion_Key is Conversion_Key_Implementation;
procedure Convert (Original : Diana.Tree;
Converted : out Diana.Tree;
Key : Conversion_Key;
Status : out Error_Status);
-- If the given tree is in one of the units recorded in the key,
-- then converts the tree to the other unit. If the tree is in
-- neither unit fails with Illegal_Operation. If the conversion
-- does not result in a valid tree node, then Consistency_Error.
function Nil return Conversion_Key;
function Is_Nil (Key : Conversion_Key) return Boolean;
function From_Segment (Key : Conversion_Key) return System.Segment;
function To_Segment (Key : Conversion_Key) return System.Segment;
type Open_Mode is --
(None, -- Mode None only applies to installed units.
-- There is no synchronization with mode None.
Read, -- Mode Read applies to either source or installed
-- units, and aquires a non-exclusive read lock
-- (exclusive of update, but not other readers).
Update -- Mode Update only applies to source units,
-- and acquires an exclusive update lock. Update
-- is exclusive of both readers and other updaters.
);
procedure Open (The_Unit : in out Ada.Version;
Mode : Open_Mode;
Result : out Root;
Key : out Conversion_Key;
Status : out Error_Status;
Action_Id : Action.Id;
Prevent_Backup : Boolean := False;
Override_Editor : Boolean := True;
Max_Wait : Duration := Default_Wait);
procedure Open (The_Unit : Ada.Unit;
Mode : Open_Mode;
Result : out Root;
Key : out Conversion_Key;
Status : out Error_Status;
Action_Id : Action.Id;
Version : Version_Name := Default_Version;
Prevent_Backup : Boolean := False;
Override_Editor : Boolean := True;
Max_Wait : Duration := Default_Wait);
procedure Open (The_Unit : Naming.Name;
Mode : Open_Mode;
Result : out Root;
Key : out Conversion_Key;
Status : out Error_Status;
Action_Id : Action.Id;
The_Context : Naming.Context := Naming.Default_Context;
Version : Version_Name := Default_Version;
Prevent_Backup : Boolean := False;
Override_Editor : Boolean := True;
Max_Wait : Duration := Default_Wait);
-- Returns the root of the separate tree designated by The_Unit.
-- Opens the unit with the specified access Mode for Action_id.
-- Opening installed units for Update is an Illegal_Operation.
-- Incompatible access modes result in queueing or Lock_Error.
-- Open may be called any number of times with the same action.
-- Opening for update after having opened for read produces a
-- conversion key for converting references between the old
-- (read only) tree and the new (writable) tree.
-- Open, Close and Save invoke policy specific pre and
-- post operations before and after execution.
procedure Save (The_Unit : Any_Node;
Status : out Error_Status;
Action_Id : Action.Id;
Immediate_Effect : Boolean := False;
Prevent_Backup : Boolean := False);
-- The unit must be open for update by the indicated action, else
-- Illegal_Operation. The current value of the unit is saved. If
-- Immediate_Effect, or when Action_Id is committed, the saved value
-- becomes the permanent value of the unit. Note that abandoning
-- Action_Id does not back out of a Save with Immediate_Effect.
-- Save with Immediate_Effect with make the_unit the default version.
-- Save will automatically update the Subclass of the Ada.Unit.
procedure Close (The_Unit : Any_Node;
Status : out Error_Status;
Action_Id : Action.Id;
Commit : Boolean := True;
Immediate_Effect : Boolean := False);
-- Closes the indicated unit, releasing access. If Commit then
-- changes become permanent and the_unit is made the default version,
-- else the previous (original or saved) value is restored.
-- It is an Illegal_Operation to close a unit not open by Action_Id.
-- Close will automatically update the Subclass of the Ada.Unit.
pragma Consume_Offset (3);
-- procedure Get_Image (The_Unit : Ada.Unit;
-- Result : out Directory.Version;
-- Status : out Error_Status;
-- Action_Id : Action.Id;
-- Version : Version_Name := Default_Version;
-- Max_Wait : Duration := Default_Wait);
-- -- Returns the file version which corresponds to the image.
procedure Reformat_Image (The_Unit : Ada.Unit;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Version : Version_Name := Default_Version;
Prevent_Backup : Boolean := False;
Override_Editor : Boolean := True;
Heap : System.Segment := Job_Segment.Get;
Max_Wait : Duration := Default_Wait);
-- This procedure will cause an entirely new image for the
-- unit to be created. This operation will work on installed units.
procedure Set_Diana_Heap
(Unit_For_Allocators : Any_Node;
Status : out Error_Status;
Attr_Space_Class : String := "";
For_Job : Default.Process_Id := Default.Nil;
For_Task : Machine.Task_Id := Machine.Nil_Task);
-- Establishes the Unit which acts as the collection for allocators
-- in Diana operations performed by the designated Job or Task.
-- If only the Job is specified, sets the unit for the Job.
-- If only the Task is specified, sets the unit for the Task.
-- If both are specified, sets the unit for the both.
-- If neither are specified, sets the unit for the current Task.
procedure Get_Diana_Heap
(Result : out Root;
Status : out Error_Status;
For_Job : Default.Process_Id := Default.Nil;
For_Task : Machine.Task_Id := Machine.Nil_Task);
-- Returns the unit associated with the designated Task or Job.
-- If only the Job is specified, gets the unit for the Job.
-- If only the Task is specified, gets the unit for the Task.
-- If neither are specified, gets the unit for the current Task.
-- If both are specified, Illegal_Operation.
-- When retrieving the unit for a Task, if no unit has been
-- specified for the Task, return the one specified for the
-- Job which contains the Task.
type Heap_State is private;
function Save_Heap return Heap_State;
procedure Restore_Heap (With_State : Heap_State);
-- Permits tools to bracket calls to set/get diana_heap.
------------------------------------------------------------------
generic
Class_Name : String;
package Attributes is
-- This package implements permament user-defined attributes of
-- arbitrary types. Users may construct a class of attributes for
-- each tool (code generator, data flow analyzer, etc.).
-- The attribute values are stored, and accessed on a per unit
-- basis. Conceptually, for a class there can be a attribute
-- space for each Ada unit (version), storing the attributes
-- for that unit. The space must be created and open before
-- any attributes may be added.
-- Permanent attributes may only be applied to installed units,
-- demoting a unit from installed will implicitly destroy all
-- attribute spaces (with the same action).
procedure Create (Any_Node : Diana.Tree;
Action_Id : Action.Id;
Status : out Error_Status;
Max_Wait : Duration := Default_Wait);
procedure Destroy (Any_Node : Diana.Tree;
Action_Id : Action.Id;
Status : out Error_Status;
Max_Wait : Duration := Default_Wait);
function Has (Any_Node : Diana.Tree) return Boolean;
function Get_Segment (Any_Node : Diana.Tree) return System.Segment;
type Access_Mode is (Update, Read);
procedure Open (Any_Node : Diana.Tree;
Mode : Access_Mode;
Status : out Error_Status;
Action_Id : Action.Id;
Max_Wait : Duration := Default_Wait);
procedure Close (Any_Node : Diana.Tree;
Status : out Error_Status;
Action_Id : Action.Id);
--------------------------------------------------------------
generic
type Attribute_Value is private;
Default_Value : Attribute_Value;
Map_Size : Integer := 101;
package Attribute is
-- This generic is instantiated once for each (unmanaged) type
-- of attribute in this class.
type Name is private;
-- The class may include several attributes of the same type,
-- distinguished by their name.
function Nil return Name;
function Is_Nil (Attr : Name) return Boolean;
function Get_Name (Symbolic_Name : String) return Name;
-- Each attribute within a class must have a unique name.
-- The first (ever) call registers this attribute name with the
-- corresponding class and type. Subsequent calls verify that
-- the symbolic name matches the type signature recorded with
-- this name for the class.
function Get (On_Node : Diana.Tree; Attr : Name)
return Attribute_Value;
function Has (Node : Diana.Tree; Attr : Name) return Boolean;
procedure Add (On_Node : Diana.Tree;
Attr : Name;
Value : Attribute_Value);
procedure Remove (From_Node : Diana.Tree; Attr : Name);
private
type Attribute_Class is
record
Value : Integer := 0;
end record;
type Name is
record
Class : Attribute_Class;
Value : Integer := 0;
end record;
end Attribute;
--------------------------------------------------------------
generic
Object_Class : Directory.Class;
Map_Size : Integer := 101;
package Managed_Attribute is
-- This package supports attributes of managed types. The
-- values do not appear in the directory system (as declared
-- entities), but otherwise have all the properties of any
-- other directory object. The Ada manager ensures that all
-- attributes of managed types are destroyed when removed or
-- when the attribute space is destroyed.
type Name is private;
-- The class may include several attributes of managed types,
-- distinguished by their attribute name.
function Nil return Name;
function Is_Nil (Attr : Name) return Boolean;
function Get_Name (Symbolic_Name : String) return Name;
-- Each attribute within a class must have a unique name.
-- The first (ever) call registers this attribute name with the
-- corresponding class and type. Subsequent calls verify that
-- the symbolic name matches the object class specified on the
-- first call.
function Get (On_Node : Diana.Tree; Attr : Name)
return Directory.Object;
function Has (Node : Diana.Tree; Attr : Name) return Boolean;
procedure Add (On_Node : Diana.Tree;
Attr : Name;
Action_Id : Action.Id);
-- Implicitly creates an object of the appropriate class with
-- the Ada unit for On_Node as its parent.
procedure Remove (From_Node : Diana.Tree;
Attr : Name;
Action_Id : Action.Id);
-- Destroys the object which is the attribute value.
private
type Attribute_Class is
record
Value : Integer := 0;
end record;
type Name is
record
Class : Attribute_Class;
Value : Integer := 0;
end record;
end Managed_Attribute;
end Attributes;
pragma Consume_Offset (1);
procedure Get_Image (The_Unit : Ada.Unit;
Result : out Directory.Version;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Version : Version_Name := Default_Version;
Max_Wait : Duration := Default_Wait);
-- Returns the file version which corresponds to the image.
-- Postponed from earlier.
function Get_Order (Root : Diana.Tree) return Directory.Subclass;
-- The Order (see below) of the unit expressed as a subclass.
end Ada;
----------------------------------------------------------------------
package Traversal is
-- Provides operations for traversing the Package Directory System
-- in a variety of ways. Note that Directory.Ada provides the
-- operations for going from an Ada.Unit or Ada.Version to the
-- actual Diana tree, and for going from any Diana node to the Unit
-- or Version. Directory.Ada (when used with Diana and various
-- utilities) also provides lower level operations for traversing the
-- Universe based on structural and semantic information.
procedure Get_Universe (Universe : out Ada.Unit;
Status : out Error_Status);
-- Returns the (somewhat special) Object corresponding to the
-- Root unit of the universe.
procedure Get_Subunit (Unit : Ada.Unit;
Subunit_Name : String;
Result : out Ada.Unit;
Status : out Error_Status;
Get_Body : Boolean := False);
-- Retrieve the named subunit.
procedure Get_Subobject (Unit : Ada.Unit;
Child_Name : String;
Result : out Directory.Object;
Status : out Error_Status);
-- Retrieve the named subobject.
procedure Get_Parent (The_Object : Directory.Object;
Result : out Ada.Unit;
Status : out Error_Status);
-- Returns the parent object for The_Object.
function Is_Visible_Part (The_Unit : Ada.Version) return Boolean;
function Is_Visible_Part
(The_Unit : Ada.Unit;
Version : Version_Name := Default_Version) return Boolean;
-- Determines whether the given unit corresponds to a visible part.
procedure Get_Other_Part (The_Unit : Ada.Version;
Complement : out Ada.Version;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Get_Other_Part (The_Unit : Ada.Unit;
Complement : out Ada.Unit;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Get_Other_Part (The_Unit : Declaration;
Complement : out Declaration;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Given the visible part, return the body, and vice versa.
-- Returns a nil unit if there is no complement.
procedure Get_Object (The_Declaration : Declaration;
Result : out Directory.Object;
Status : out Error_Status;
The_Class : Directory.Class := Nil;
Prevent_Create : Boolean := False;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Given the declaration, returns the Object. If The_Declaration
-- does not correspond to a managed directory object, then fails
-- with consistency error.
procedure Get_Declaration (Root : Ada.Root;
Object_Name : String;
Result : out Declaration;
Status : out Error_Status;
Stubs_Only : Boolean := False);
-- Return the declaration with the corresponding name if it
-- appears in the unit. If Stubs_Only is true, then only
-- declarations of managed objects and stubs will be returned.
procedure Get_Declaration (The_Object : Directory.Object;
Parent : Ada.Version;
Result : out Declaration;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Get_Declaration
(The_Object : Directory.Object;
Result : out Declaration;
Status : out Error_Status;
Parent_Version : Version_Name := Default_Version;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Returns the declaration corresponding to this object.
-- If the parent is a source unit and Action_Id is not
-- the Null_Id, will acquire read access to the parent
-- Ada version containing the stub declaration.
procedure Get_Version (The_Object : Directory.Object;
Result : out Directory.Version;
Status : out Error_Status;
Version : Version_Name := Default_Version;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Retrieves the specified version of The_Object, used
-- wherever one must get from an object to a specific version.
procedure Get_Object (The_Version : Version;
Result : out Directory.Object;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Returns the Object which has The_Version as one of its versions.
type Object_Iterator is private;
-- For iterating over all of the managed objects in an Ada unit.
-- Includes Objects for which no versions have been created.
-- This form of iterator is much less efficient than the
-- Subunit_Iterator or Subobject_Iterator.
procedure Init (The_Unit : Ada.Version;
Action_Id : Action.Id;
Iterator : out Object_Iterator;
Status : out Error_Status;
Max_Wait : Duration := Default_Wait);
-- Initializes the iteration over the ada unit, aquiring
-- read access to the Ada.Version if a Action_Id is not null.
procedure Next (Iterator : in out Object_Iterator);
function Value (Iterator : Object_Iterator) return Directory.Object;
function Done (Iterator : Object_Iterator) return Boolean;
type Subunit_Iterator is private;
-- For iterating over subunits, independent of version.
procedure Init (The_Unit : Ada.Unit;
Action_Id : Action.Id;
Iterator : out Subunit_Iterator;
Status : out Error_Status;
Max_Wait : Duration := Default_Wait);
-- Initializes the iteration over The_Unit. Gets a read lock
-- on the object.
procedure Next (Iterator : in out Subunit_Iterator);
function Value (Iterator : Subunit_Iterator) return Ada.Unit;
function Done (Iterator : Subunit_Iterator) return Boolean;
type Version_Iterator is private;
-- For iterating over all versions of some object.
procedure Init (The_Object : Directory.Object;
Action_Id : Action.Id;
Versions : out Version_Iterator;
Status : out Error_Status;
Max_Wait : Duration := Default_Wait;
Forward : Boolean := True);
-- Initializes the iteration over The_Unit. Gets a read lock
-- on the object.
procedure Next (Versions : in out Version_Iterator);
function Value (Versions : Version_Iterator) return Version;
function Value (Versions : Version_Iterator) return Version_Name;
function Done (Versions : Version_Iterator) return Boolean;
type Associated_Object_Iterator is limited private;
-- For iterating over all of the associated objects in an Ada unit.
-- Includes Attribute spaces, list file directory.objects, etc.
procedure Init (The_Version : Ada.Version;
Iterator : out Associated_Object_Iterator;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Initializes the iteration over the ada unit.
procedure Next (Iterator : in out Associated_Object_Iterator);
function Value (Iterator : Associated_Object_Iterator) return Version;
function Done (Iterator : Associated_Object_Iterator) return Boolean;
type Subobject_Iterator is private;
-- For iterating over subobjects, independent of version or class.
procedure Init (The_Unit : Ada.Unit;
Action_Id : Action.Id;
Iterator : out Subobject_Iterator;
Status : out Error_Status;
Max_Wait : Duration := Default_Wait);
-- Initializes the iteration over The_Unit. Gets a read lock
-- on the object.
procedure Next (Iterator : in out Subobject_Iterator);
function Value (Iterator : Subobject_Iterator) return Directory.Object;
function Done (Iterator : Subobject_Iterator) return Boolean;
end Traversal;
----------------------------------------------------------------------
package Declaration_Operations is
-- Operations to promote and demote declarations. Promoting
-- declarations moves them "up" to higher declaration states
-- (toward Coded), while demotion moves declarations
-- "down" to lower declaration states (toward Nonexistent).
type Declaration_State is
(Nonexistent,
Archived, -- Text-only source, must be parsed.
Source, -- Source, may be ready to be compiled.
Installed, -- Semantically consistent.
Coded -- Has been code generated.
);
procedure Get_Unit_State (For_Unit : Ada.Version;
Result : out Declaration_State;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Get_Unit_State (For_Unit : Ada.Unit;
Result : out Declaration_State;
Status : out Error_Status;
Version : Version_Name := Default_Version;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Get_Unit_State (For_Unit : Ada.Root;
Result : out Declaration_State;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- For the unit return the current declaration state.
function Is_Source (For_Unit : Ada.Version) return Boolean;
function Is_Installed (For_Unit : Ada.Version) return Boolean;
function Is_Source (For_Node : Ada.Any_Node) return Boolean;
function Is_Installed (For_Node : Ada.Any_Node) return Boolean;
-- Fast forms.
procedure Promote (Stub : in out Ada.Stub;
Errors : out Error_Messages.Errors;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Goal_State : Declaration_State := Installed;
Switches : Switches_Type := Directory.Nil;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- If the stub is actually a program unit stub declaration (rather
-- than a nonterminal), attempts to promote the associated subunit
-- to the Target_State. A subunit may not be promoted to a state
-- higher than that of the stub declaration, except that a subunit
-- may be coded before the unit containing the stub is coded. If
-- not yet installed, the subunit may actually be a program unit
-- declaration rather than a subunit comp_unit, in which case
-- the comp_unit shell will be constructed automatically, using
-- the declaration as the AS_Subunit_Body.
-- If the stub is a nonterminal (insertion_point), then attempts
-- to insert the associated tree at the nonterminal, promoting
-- it to the state of the enclosing unit (ignores Target_State).
-- If the associated unit is a subunit, a package (body or
-- real spec, not rename or instantiation), a task body, or a
-- subprogram body then a stub is constructed and promoted in
-- place of the nonterminal, and then the separate unit is promoted
-- as if it were a subunit (see above), using the specified
-- Target_State. Otherwise, the associated unit must be either a
-- declaration, a statement, or a list of either statements or
-- declarations, which will be inserted in place of the nonterminal
-- and promoted to the state of the enclosing unit, and then destroyed.
-- See Directory.Control point for limitations on when incremental
-- operations are available. Basically, incremental installation
-- is available everywhere, incremental coding is available only
-- rarely.
-- May fail with semantic, obsolescence or various other errors.
procedure Demote (Location : Diana.Tree;
Errors : out Error_Messages.Errors;
Result : out Diana.Tree;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Count : Natural := 1;
Goal_State : Declaration_State := Source;
Switches : Switches_Type := Directory.Nil;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Location may be an item (or def_id for an item), statement,
-- comp_unit (a diana.dn_comp_unit or the root of the unit), or
-- nonterminal. In the first two of those cases, the Count
-- parameter may be used to demote a sequence of declarations
-- or statements, which will be demoted to source in a separate
-- unit associated with a nonterminal left at the point of the
-- demotion (unless the Target_State is Nonexistent). If a program
-- unit stub with an associated subunit is demoted in this manner,
-- the stub is replaced by a nonterminal which is now associated
-- with the subunit and the stub no longer exists.
-- For comp_units, any target state may be specified, and the
-- unit will be demoted to that state. For items, the current
-- unit must either be in a control point or must be in the
-- state Installed. For statements, the current unit must
-- be Installed. For both items and statements, the final
-- state must be either Source or Nonexistent.
-- Stubs may only be demoted individually, with Count = 1.
-- Nonterminals may only be demoted individually, and only to the
-- Nonexistent state.
-- This operation will fail with obsolescence error if any
-- declarations (including installed subunits) depend upon
-- demoted declarations.
procedure Open_Insertion_Point (Decl_Stm_S : Diana.Tree;
Position : Natural := Default_Position;
Status : out Error_Status;
Result : out Diana.Tree;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Returns the Dn_Nonterminal inserted at the given position
-- (A position of 0 implies before the first element of the list).
-- If Decl_Stm_S is in a source unit, this operation will open the
-- unit for update with the given action (else Lock_Error).
-- Within source it is not legal to associate a unit with a
-- nonterminal, although a nonterminal in a source unit may
-- already have an associated object which was created when
-- the unit was installed. The nonterminal is given a unique
-- name which identifies any associated unit.
procedure Will_Be_A_Comp_Unit (Root : Diana.Tree;
Result : out Boolean;
Status : out Error_Status);
-- A predicate which determines if the root of a child unit will
-- be promoted in place or made into a comp_unit.
procedure Get_Unit_State (For_Unit : Ada.Root;
Result : out Declaration_State;
Status : out Error_Status;
Key : Directory.Target_Key;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- This special form of Get_Unit_State is intended for use
-- by people who already have a target_key, and don't (or can't)
-- suffer through access_control to look one up in a switch file.
procedure Promote (Stub : in out Ada.Stub;
Preserve_Partial_Info : in out Boolean;
Errors : out Error_Messages.Errors;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Goal_State : Declaration_State := Installed;
Switches : Switches_Type := Directory.Nil;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- If Preserve_Partial_Info is passed in true, directory will try
-- to arrange things so that the action passed can be committed even
-- if an error occurs. If this is the case, Preserve_Partial_Info will
-- return True. Otherwise the action should be abandoned on failure.
procedure Open_Insertion_Point
(Decl_Stm_S : Diana.Tree;
Position : Natural := Default_Position;
Errors : out Error_Messages.Errors;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Result : out Diana.Tree;
Switches : Switches_Type := Directory.Nil;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- A new, improved version of Open_Insertion_Point which
-- allows the code generator to return status.
procedure Demote_List (Items : Diana.Temp_Seq;
Errors : out Error_Messages.Errors;
Result : out Diana.Temp_Seq;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Goal_State : Declaration_State := Source;
Switches : Switches_Type := Directory.Nil;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
end Declaration_Operations;
----------------------------------------------------------------------
package Object_Operations is
-- Operations to Create, Copy and Destroy Objects.
procedure Create (The_Object : Directory.Object;
Result : out Version;
Errors : out Error_Messages.Errors;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Initial_Value : Version_Name := Nil_Version;
The_Version : Version_Name := New_Version;
Switches : Switches_Type := Directory.Nil;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Create (Object_Name : Naming.Simple_Name;
Parent : Ada.Unit;
Result : out Version;
Errors : out Error_Messages.Errors;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Object_Class : Class := Nil;
Object_Subclass : Subclass := Nil;
Initial_Value : Version_Name := Nil_Version;
The_Version : Version_Name := New_Version;
Parent_Version : Version_Name := Default_Version;
Position : Natural := Default_Position;
Switches : Switches_Type := Directory.Nil;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Create (Object_Name : Naming.Name;
Result : out Version;
Errors : out Error_Messages.Errors;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Object_Class : Class := Nil;
Object_Subclass : Subclass := Nil;
The_Context : Naming.Context :=
Naming.Default_Context;
Initial_Value : Version_Name := Nil_Version;
The_Version : Version_Name := New_Version;
Position : Natural := Default_Position;
Switches : Switches_Type := Directory.Nil;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- For The_Object, creates a new version. The The_Version
-- parameter determines the name of the newly created version.
-- An existing version may be designated as the Initial_Value.
-- If The_Version designates an existing version, or Initial_Value
-- designates a non-existant one, then Illegal_Operation. If the
-- named entity is not declared first create a declaration (at
-- the given Position in the parent declarative part) with the given
-- name, using the class to determine the type. If there is
-- no declaration and the class is nil, then Consistency_Error.
-- When creating an Ada object where no initial value is specified,
-- creates an unit with a skeletal completion of the stub
-- declaration.
-- Non-ada objects (including libraries) can only be created
-- immediately inside libraries.
procedure Copy (Source : Version;
Destination : in out Version;
Errors : out Error_Messages.Errors;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Make_Default : Boolean := True;
Switches : Switches_Type := Directory.Nil;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Copy (Source : Directory.Object;
Destination_Object : Directory.Object;
Errors : out Error_Messages.Errors;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Source_Version : Version_Name := Default_Version;
Destination_Version : Version_Name := New_Version;
Make_Default : Boolean := True;
Switches : Switches_Type := Directory.Nil;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Copy (Source : Directory.Object;
Destination_Parent : Ada.Unit;
Destination_Name : Naming.Simple_Name;
Result : out Directory.Object;
Errors : out Error_Messages.Errors;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Source_Version : Version_Name := Default_Version;
Destination_Version : Version_Name := New_Version;
Parent_Version : Version_Name := Default_Version;
Make_Default : Boolean := True;
Position : Natural := Default_Position;
Switches : Switches_Type := Directory.Nil;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Copy (Source : Naming.Name;
Destination : Naming.Name;
Result : out Directory.Object;
Errors : out Error_Messages.Errors;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Source_Context : Naming.Context :=
Naming.Default_Context;
Source_Version : Version_Name := Default_Version;
Destination_Context : Naming.Context :=
Naming.Default_Context;
Destination_Version : Version_Name := New_Version;
Make_Default : Boolean := True;
Position : Natural := Default_Position;
Switches : Switches_Type := Directory.Nil;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Copies the value. Creates an entirely new declaration and object
-- at the destination if one did not exist. If the declaration
-- existed, but the specified Destination_Version did not, creates
-- a new version of the object. If the destination version already
-- exists, overwrites the old value with the new. Copied Ada
-- units are source only, regardless of the state of the Source.
-- Copies only the Source object (no sub-objects).
-- A Version_Name of All_Versions may be used with copy, causing
-- all versions of the object to be copied.
procedure Destroy (The_Version : Version;
Errors : out Error_Messages.Errors;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Switches : Switches_Type := Directory.Nil;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Destroy (The_Object : Directory.Object;
Errors : out Error_Messages.Errors;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Version : Version_Name := Default_Version;
Switches : Switches_Type := Directory.Nil;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Destroy (The_Object : Naming.Name;
Errors : out Error_Messages.Errors;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
The_Context : Naming.Context :=
Naming.Default_Context;
Version : Version_Name := Default_Version;
Switches : Switches_Type := Directory.Nil;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Destroys the specified version of the object. Specifying
-- All_Versions will destroy all of the versions of the object.
-- If the target of any destroy is an installed Ada unit, first
-- attempts to withdraw the unit, then (if there were no errors)
-- performs the destroy.
-- A Version_Name of All_Versions may be used with Destroy, causing
-- all versions of the object to be Destroyed.
procedure Create_Package
(Name : Naming.Simple_Name;
Parent : Ada.Unit;
Result : out Ada.Unit;
Status : out Error_Status;
Part : Package_Part := Visible_Part;
Parent_Version : Version_Name := Default_Version;
Spec_Position : Natural := Default_Position;
Body_Position : Natural := Default_Position;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Creates a source version of a package.
procedure Recreate (The_Object : Directory.Object;
Initial_Value : Directory.Version;
Status : out Error_Status;
The_Version : Version_Name := New_Version;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Recreate (Object_Name : Naming.Simple_Name;
Parent : Ada.Unit;
Initial_Value : Directory.Version;
Status : out Error_Status;
The_Version : Version_Name := New_Version;
Parent_Version : Version_Name := Default_Version;
Position : Natural := Default_Position;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Recreate (Object_Name : Naming.Name;
Initial_Value : Directory.Version;
Status : out Error_Status;
The_Context : Naming.Context :=
Naming.Default_Context;
The_Version : Version_Name := New_Version;
Position : Natural := Default_Position;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- For The_Object, associates the specified Initial_Value as
-- a version of that object. The Initial_Value must be an
-- unrooted object, which has the null object as its parent.
-- The Version parameter determines the name of the version.
-- If the given Initial_Value is already a version of The_Object,
-- then the recreate is a no-op. If the named entity is not
-- declared first create a declaration (at the given Position
-- in the parent declarative part) with the given name, using
-- the class to determine the type. If there is no declaration
-- and the class is nil, then Consistency_Error.
procedure Is_Frozen (The_Object : Directory.Object;
Result : out Boolean;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Test whether an object is frozen.
procedure Freeze_Object (The_Object : Directory.Object;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Freeze_Unit (The_Unit : Ada.Unit;
Recursive : Boolean;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Freeze an object or a unit (and its children which are in the
-- same control point) so that it cannot be changed.
procedure Unfreeze_Object (The_Object : Directory.Object;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Unfreeze_Unit (The_Unit : Ada.Unit;
Recursive : Boolean;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Unfreeze an object or a unit (and its children which are in
-- the same control point) so that it can be manipulated normally.
procedure Set_Default (The_Object : Directory.Object;
New_Default : Directory.Version;
Errors : out Error_Messages.Errors;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Switches : Switches_Type := Directory.Nil;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Change the Default_Version of an object. Naturally, New_Default
-- must be either an existing version of The_Object or Nil.
procedure Expunge_Object
(The_Object : Directory.Object;
Status : out Error_Status;
Retention_Count : Integer := Default_Retention_Count;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Expunge_Unit
(The_Unit : Ada.Unit;
Recursive : Boolean;
Status : out Error_Status;
Retention_Count : Integer := Default_Retention_Count;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Expunge (destroy) excess deleted versions or an object or unit
-- (and its children which are in the same control point).
procedure Get_Retention_Count (The_Object : Directory.Object;
Result : out Natural;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Set_Retention_Count
(The_Object : Directory.Object;
Retention_Count : Integer := Default_Retention_Count;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Manipulate the number of deleted versions to retain.
-- Setting to a negative number (e.g., Default_Retention_Count) means
-- set to the parent's retention count.
procedure Create_Backup (The_Object : Directory.Object;
Status : out Error_Status;
Version : Version_Name := Default_Version;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Increment The_Version's version number, and copy it to a new
-- version with the original number.
procedure Set_Subclass (The_Object : Directory.Object;
The_Subclass : Directory.Subclass;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Reset_Subclass (The_Object : Directory.Object;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Change the subclass of an object. The new subclass must still
-- have the same parent class as the object.
-- Reset_Subclass will attempt to deduce the proper subclass.
-- If the proper subclass isn't obvious, nil will be used.
function No (An_Object : Directory.Object;
Action_Id : Action.Id;
Max_Wait : Duration) return Boolean;
generic
Subclass_Name : String;
Parent_Class : Directory.Class;
with function Is_Mine (An_Object : Directory.Object;
Action_Id : Action.Id;
Max_Wait : Duration) return Boolean is No;
package Registered_Subclass is
function Value return Directory.Subclass;
end Registered_Subclass;
-- Returns Nil if instantiation is illegal.
procedure Is_Slushy (The_Object : Directory.Object;
Result : out Boolean;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Test whether an object is slushy.
procedure Set_Slushy (The_Object : Directory.Object;
Value : Boolean;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Make an object slushy or normal.
procedure Is_Controlled (The_Object : Directory.Object;
Result : out Boolean;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Test whether an object is controlled.
procedure Set_Controlled (The_Object : Directory.Object;
Value : Boolean;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Make an object controlled or normal.
procedure Rename (The_Object : Directory.Object;
New_Parent : Directory.Object;
New_Name : Naming.Simple_Name;
Errors : out Error_Messages.Errors;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Rename (The_Object : Naming.Name;
New_Name : Naming.Name;
Result : out Directory.Object;
Errors : out Error_Messages.Errors;
Change_Impact : out Ada.Roots;
Modified_Units : out Diana.Temp_Seq;
Status : out Error_Status;
Change_Limits : Object_Set.Set := Object_Set.Nil;
Limit_Type : Change_Limit := Object_Only;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Rename (The_Object : Directory.Object;
New_Parent : Directory.Object;
New_Name : Naming.Simple_Name;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Rename (The_Object : Naming.Name;
New_Name : Naming.Name;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Give The Object a New Name. If The Object is a world, or The
-- Object is in the same world as its New Parent, no data is
-- transferred; otherwise Rename is equivalent (literally) to a Copy
-- followed by a Destroy, moving The Object and all versions.
-- Directories can be renamed if no data transfer is required.
-- The last two forms give less information when the Rename
-- fails; they are more appropriate for renaming non-Ada
-- objects.
end Object_Operations;
----------------------------------------------------------------------
package Policy is
type Open_Mode is (None, Read, Update, Overwrite);
procedure Pre_Open (The_Object : Directory.Object;
The_Version : in out Directory.Version;
Mode : Policy.Open_Mode;
Status : out Error_Status;
Action_Id : Action.Id;
Max_Wait : Duration;
Prevent_Backup : Boolean);
procedure Post_Open (The_Object : Directory.Object;
The_Version : Directory.Version;
Mode : Policy.Open_Mode;
Status : out Error_Status;
Action_Id : Action.Id;
Max_Wait : Duration);
procedure Pre_Save (The_Object : Directory.Object;
The_Version : Directory.Version;
Status : out Error_Status;
Action_Id : Action.Id;
Max_Wait : Duration;
Prevent_Backup : Boolean);
procedure Post_Save (The_Object : Directory.Object;
The_Version : Directory.Version;
Status : out Error_Status;
Action_Id : Action.Id;
Max_Wait : Duration);
procedure Pre_Close (The_Object : Directory.Object;
The_Version : Directory.Version;
Commit : Boolean;
Status : out Error_Status;
Action_Id : Action.Id;
Max_Wait : Duration);
procedure Post_Close (The_Object : Directory.Object;
The_Version : Directory.Version;
Commit : Boolean;
Status : out Error_Status;
Action_Id : Action.Id;
Max_Wait : Duration);
procedure Compilation_Info (The_Object : Directory.Object;
Result : out Target_Key;
Switches : in out Switches_Type;
Status : out Error_Status;
Action_Id : Action.Id;
Max_Wait : Duration);
end Policy;
----------------------------------------------------------------------
package Control_Point is
subtype Unit is Ada.Unit;
-- A unit corresponding to the root of a control_point.
-- A control_point corresponds either to a library and all of
-- the library units in that library, or to a package in the
-- package hierarchy and all of the subunits of that package
-- (not including nested control_points and their contents).
type Kind is (Library_Control_Point, Directory_Control_Point, None);
function Image (Cp_Kind : Kind) return String;
function Value (Cp_Kind : String) return Kind;
function Get_Class return Directory.Class;
-- Returns the Class of Libraries (Directory_Manager.Class).
function Is_Control_Point (Unit : Ada.Unit) return Boolean;
function Is_Control_Point (Unit : Directory.Object) return Boolean;
-- Returns true IFF the indicated Unit is the root of a control_point.
function Is_World (Unit : Ada.Unit) return Boolean;
function Is_World (Unit : Directory.Object) return Boolean;
function Is_Directory (Unit : Ada.Unit) return Boolean;
function Is_Directory (Unit : Directory.Object) return Boolean;
function Kind_Of_Control_Point
(Any_Object : Directory.Object) return Control_Point.Kind;
-- Returns None if Unit is not a control point.
function Kind_Of_Associated_Control_Point
(Any_Object : Directory.Object) return Control_Point.Kind;
function Associated_Control_Point
(The_Object : Directory.Object) return Control_Point.Unit;
function Associated_Control_Point
(The_Object : Directory.Object) return Directory.Object;
-- Returns the nearest enclosing control_point unit which contains
-- the specified object.
procedure Enclosing_World (The_Object : Directory.Object;
The_World : out Control_Point.Unit;
Status : out Error_Status);
procedure Enclosing_Directory (The_Object : Directory.Object;
The_Directory : out Control_Point.Unit;
Status : out Error_Status);
procedure Set_Switch_Object (Unit : Control_Point.Unit;
The_File : Directory.Object;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Get_Switch_Object (Unit : Control_Point.Unit;
The_File : out Directory.Object;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Used to manipulate the file object used to store switch files.
subtype Volume is Natural range 0 .. 31;
-- Used to represent a disk volume.
function Nil return Volume;
function Is_Nil (The_Volume : Volume) return Boolean;
function Get_Volume
(The_Control_Point : Control_Point.Unit) return Volume;
procedure Create (Name : Naming.Simple_Name;
Kind : Control_Point.Kind;
Parent : Control_Point.Unit;
Result : out Control_Point.Unit;
Status : out Error_Status;
The_Subclass : Subclass := Nil;
Vol : Volume := Nil;
Spec_Position : Natural := Default_Position;
Body_Position : Natural := Default_Position;
Part : Package_Part := Both_Parts;
Parameters : Directory.Object := Nil;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Creates a new control_point at the indicated position.
-- If an appropriate stub already exists and has no directory
-- object associated with it, that stub will be reused rather
-- than creating a new one.
-- All objects contained within the control_point are created on the
-- volume associated with the World and all such objects abide
-- by the policies associated with the world.
procedure Compact (Unit : Control_Point.Unit;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- This experimental procedure will attempt to reduce the
-- size of the diana tree for a control point. Some programs
-- may break because the diana.tree for all stubs in the unit
-- will be changed by this operation.
pragma Consume_Offset;
procedure Get_Target_Key (The_Object : Directory.Object;
The_Key : out Directory.Target_Key;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Get_Target_Key (The_Object : Directory.Version;
The_Key : out Directory.Target_Key;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Get_Target_Key (The_Object : Ada.Root;
The_Key : out Directory.Target_Key;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Returns the target key associated with the given object.
-- Returns the nil target key if one has not yet been assigned.
-- A read lock on the enclosing world object is obtained if a
-- non-null action id is provided
procedure Parent_World (The_Object : Directory.Object;
The_World : out Control_Point.Unit;
Status : out Error_Status);
procedure Parent_World (The_Object : Directory.Object;
The_World : out Directory.Object;
Status : out Error_Status);
procedure Parent_Library (The_Object : Directory.Object;
The_Library : out Control_Point.Unit;
Status : out Error_Status);
procedure Parent_Library (The_Object : Directory.Object;
The_Library : out Directory.Object;
Status : out Error_Status);
-- Returns the world (or library) that encloses the given
-- object. Unlike Enclosing_World (Enclosing_Directory), the
-- Parent_World (Parent_Library) of a world (library) is NOT the world
-- (library) itself, but the world (library) that properly
-- contains the world (library). The object returned by
-- Enclosing_Library may be a world or a directory. The parent
-- world/directory of the universe object is Directory.Nil.
end Control_Point;
----------------------------------------------------------------------
type Statistics_Data_Implementation is private;
package Statistics is
subtype User is Directory.Object;
subtype Session is Directory.Object;
subtype Data is Statistics_Data_Implementation;
procedure Get_Data (The_Object : Directory.Object;
The_Data : out Data;
Status : out Error_Status;
Version : Version_Name := Default_Version;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Get_Data (The_Version : Version;
The_Data : out Data;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
function Time_Of_Last_Update (The_Data : Data) return Calendar.Time;
function Time_Of_Last_Read (The_Data : Data) return Calendar.Time;
function Time_Of_Creation (The_Data : Data) return Calendar.Time;
function Last_Updater (The_Data : Data) return User;
function Session_Of_Last_Updater (The_Data : Data) return Session;
function Last_Reader (The_Data : Data) return User;
function Session_Of_Last_Reader (The_Data : Data) return Session;
function Creator (The_Data : Data) return User;
function Session_Of_Creator (The_Data : Data) return Session;
function Total_Size (The_Data : Data) return Long_Integer;
function Header_Size (The_Data : Data) return Natural;
function Data_Size (The_Data : Data) return Long_Integer;
procedure Get_Last_Edit_Time (The_Unit : Ada.Unit;
The_Time : out Calendar.Time;
Status : out Error_Status;
Version : Version_Name := Default_Version;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Get_Last_Edit_Time (The_Version : Ada.Version;
The_Time : out Calendar.Time;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
procedure Get_Last_Edit_Time (The_Unit : Ada.Any_Node;
The_Time : out Calendar.Time;
Status : out Error_Status);
type Object_Data is private;
procedure Get_Object_Data
(The_Object : Directory.Object;
The_Data : out Object_Data;
Status : out Directory.Error_Status;
Library_Info : Boolean := False;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Directory.Default_Wait);
-- Obtains information about the given object. If Library_Info is
-- true, the switch file and target key controlling the object
-- are returned for any object. If Library_Info is false, this
-- information is returned only for library (nee control point)
-- objects.
function Object_Parent (The_Data : Object_Data) return Directory.Object;
-- Only the universe object has no parent
function Object_Class (The_Data : Object_Data) return Directory.Class;
function Object_Subclass (The_Data : Object_Data)
return Directory.Subclass;
-- The subclass of the default version of the object
function Object_Volume (The_Data : Object_Data)
return Control_Point.Volume;
-- Volume the object resides on.
function Object_Library (The_Data : Object_Data)
return Directory.Object;
-- The library that immediately contains the object.
function Object_Library_Kind
(The_Data : Object_Data) return Control_Point.Kind;
-- Directory or World: If the data is for a library object then
-- this function returns the kind of that library. If the object
-- is not a library, this function returns the kind of the
-- enclosing library.
function Object_Retention_Count (The_Data : Object_Data) return Natural;
function Object_Is_Frozen (The_Data : Object_Data) return Boolean;
function Object_Id_Slushy (The_Data : Object_Data) return Boolean;
function Object_Is_Controlled (The_Data : Object_Data) return Boolean;
function Object_Is_Library (The_Data : Object_Data) return Boolean;
function Object_Child_Count (The_Data : Object_Data) return Natural;
-- Number of immediate subcomponents of the object. Includes
-- deleted-but-not-destroyed objects.
function Object_Version_Count (The_Data : Object_Data) return Natural;
-- Number of extant versions of the object; includes the default
-- version, if any.
function Object_Default_Version
(The_Data : Object_Data) return Directory.Version;
-- Returns the Nil version if Object has not default (i.e., is
-- deleted).
function Object_Unit_State
(The_Data : Object_Data)
return Directory.Declaration_Operations.Declaration_State;
-- For Ada objects only. Returns the unit state for the default
-- version of the object.
function Object_Switch_File
(The_Data : Object_Data) return Directory.Object;
-- Switch file associated with the Object's library
function Object_Target_Key (The_Data : Object_Data)
return Directory.Target_Key;
-- Target Key associated with the Object.
function Object_Is_Slushy (The_Data : Object_Data) return Boolean
renames Object_Id_Slushy;
-- Compatible fix to typo earlier in spec.
function Object_Order (The_Data : Object_Data)
return Directory.Subclass;
-- The Order (see below) of the default version of the object
-- expressed as a subclass.
end Statistics;
pragma Consume_Offset (1);
-- An object also has a CATEGORY, which is orthogonal to its subclass.
type Category is (Resident, Gateway, Spare2, Spare3);
procedure Set_Category (Object : Directory.Object;
Category : Directory.Category;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Sets the category for the default version. Its Subclass is
-- unaffected.
function Get_Category (Object : Directory.Object) return Category;
function Has_Category
(Object : Directory.Object; Category : Directory.Category)
return Boolean;
function Is_Resident (Object : Directory.Object;
Category : Directory.Category := Directory.Resident)
return Boolean renames Directory.Has_Category;
function Is_Gateway (Object : Directory.Object;
Category : Directory.Category := Directory.Gateway)
return Boolean renames Directory.Has_Category;
-- The unique classification of an object according to its category
-- and subclass is called its ORDER.
type Order is
record
Category : Directory.Category;
Subclass : Directory.Subclass;
end record;
procedure Set_Order (Object : Directory.Object;
Order : Directory.Order;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Default_Wait);
-- Sets the Categrory and Subclass of the default version of the
-- specified object.
function Get_Order (Object : Directory.Object) return Directory.Order;
-- The Order of an object can be expressed as a Subclass. All procedures
-- and functions that accept a parameter of type Directory.Subclass
-- actually interpret their parameters as Orders. But, all functions that
-- previously returned Directory.Subclass (except Subclass_Value and
-- Registered_Subclass.Value), return a pure Subclass, NOT an Order. New
-- functions (all called Get_Order) have been added to return the Order as
-- a subclass, in these cases. Subclass_Value and Registered_Subclass.-
-- Value also return Subclass values that refect both category and subclass.
-- Our expectation is that most components of the system will want
-- to continue to traffic in pure subclasses and only a few clients
-- will have to deal with orders.
function Get_Order (Object : Directory.Object) return Directory.Subclass;
function Order_Subclass (Order : Directory.Subclass)
return Directory.Subclass;
function Order_Category (Order : Directory.Subclass)
return Directory.Category;
function Convert (Order : Directory.Order) return Directory.Subclass;
function Convert (Order : Directory.Subclass) return Directory.Order;
pragma Inline (Convert, Order_Category, Order_Subclass);
end Directory;package Editor_Interface is
pragma Subsystem (Core_Editor);
pragma Module_Name (4, 2010);
-- A simple and very limited programmatic interface to the editor.
-- It operates at the same level as the package !Commands.Editor,
-- except it is more convenient to write programs against (as
-- opposed to binding keys).
-- a reference to a particular window on a particular image.
type Image_Handle is private;
Null_Image_Handle : constant Image_Handle;
function Is_Valid (The_Image : Image_Handle) return Boolean;
function Hash (The_Handle : Image_Handle) return Long_Integer;
type Point is
record
Line : Natural;
Column : Natural;
end record;
Null_Point : constant Point := Point'(Line => 0, Column => 0);
First_Point : constant Point := Point'(Line => 1, Column => 1);
-- Exceptions: some procedures below raise exceptions in error
-- conditions. In this case the action requested is not attempted,
-- but no error message is given to the user.
-- Raised as indicated below when the calling program is not
-- running in the foreground.
User_Interrupted : exception;
-- Raised on unindentified internal problems
Internal_Error : exception;
-- Raised on attempts to modify read-only or busy buffers.
Read_Only_Error : exception;
-- Raised on attempts to modify protected regions (such as in
-- the mail oe)
Protection_Error : exception;
package Image_Access is
-- Get the handle for a the image containing the user's cursor.
-- can raise User_Interrupted.
function Get_Handle return Image_Handle;
-- Name of the Oe that owns this image.
-- It is generally bad practice to depend too heavily
-- on the string value returned here.
function Oe_Name (The_Image : Image_Handle) return String;
-- Name of this image. Often this corresponds to the
-- Directory object represented by the image, but this is
-- not guaranteed. The name is not neccessarily unique.
-- If running in the background, there is a small chance the
-- name will change sometime after the call.
function Image_Name (The_Image : Image_Handle) return String;
-- Returns cursor position on the window indicated by the handle
function Get_Cursor (The_Image : Image_Handle) return Point;
-- Return the beginning and end points of the selection, if it
-- is on the window indicated by the handle. Otherwise return
-- null points.
procedure Get_Selection (The_Image : Image_Handle;
First, Last : out Point);
-- Returns the last point in the image.
function Bottom (The_Image : Image_Handle) return Point;
-- Put the users cursor at point, and make that point visible.
-- Could raise User_Interrupted.
-- If Cursor.Line or Column is 0 then raises Constraint_Error.
procedure Set_Cursor (The_Image : Image_Handle; Cursor : Point);
type Designation is (Text, Prompt, Protected);
type Designation_String is array (Positive range <>) of Designation;
type Line_Contents (Length : Natural) is
record
Designations : Designation_String (1 .. Length);
Text : String (1 .. Length);
end record;
-- Return the contents of indicated line.
-- Could raise User_Interrupted.
-- If Line is past the end of the file, returns the empty contents
-- (length = 0).
function Contents_Of (The_Image : Image_Handle; Line : Positive)
return Line_Contents;
-- Replace a portion of the text for a line. Side effect of
-- this operation will be to move the cursor.
-- Could raise User_Interrupted, Read_Only_Error,
-- Protection_Error, or Constraint_Error (if P.Line or Column
-- is 0).
-- The modification behaves much as if the user typed it:
-- The half-plane model is respected (if P is past the end of the
-- file or past the end of a line, empty lines or blanks (respectively)
-- are inserted. Note the if the line or column of P is very
-- far from the edge of the buffer, massive amounts of disk space
-- will be consumed in this process).
-- Prompts will be deleted as neccessary. Note this implies that
-- the number of characters actually deleted may be greater than
-- Old_Length, and that the first point of the resulting text may be
-- before P in the image-- it may even be on a earlier line.
-- After the call P will indicate the place where the insertion
-- actually took place, which will differ from the value of P
-- P before the call in the case of prompts.
-- It is the responsibility of the caller to give the user
-- an error message when exceptions are raised.
procedure Replace_Text (The_Image : Image_Handle;
P : in out Point;
Old_Length : Natural;
New_Text : String);
end Image_Access;
-- An underline spans Length characters from Start. Underlines
-- may overlap, but cannot extend past a line, or span more than
-- one line. The Value is a piece of information put by the
-- underliner that can be used by the underline coupler to process
-- the underline when the Explain procedure is called
type Underline is
record
Start : Point;
Length : Natural;
Value : Long_Integer;
end record;
Null_Underline : constant Underline :=
Underline'(Start => Null_Point, Length => 0, Value => 0);
-- This generic is used to put underlines on the image. The instan-
-- tiator's Explain procedure will get called when the Explain button
-- is pressed with the cursor on an underline made by it.
-- WARNING: The instantiator's Explain procedure is called on a
-- session thread (a task that is associated with the
-- user's session), and could cause the user's session
-- to lock up if it deadlocks or goes into an infinite
-- loop. It is expected that the Explain procedure will
-- do simple and cheap operations when called, like give
-- a simple message with the explanation.
generic
-- This procedure gets called when the Explain button is pressed.
with procedure Explain (The_Image : Image_Handle; U : Underline);
package Underline_Manager is
-- Makes a new underline in Image. Also puts in the coupler
-- key for the instantiation in with the underline. This will
-- be used to call Explain. Cursor is not moved.
procedure Make (The_Image : Image_Handle; U : Underline);
-- Removes underlines which overlap the region between First and
-- Last (both inclusive). All underlines upto a certain point can
-- be removed by making First as First_Point, and Last as the des-
-- ired point. Likewise all underlines from a certain point can
-- be removed by making First the desired point, and Last the bot-
-- tom of the image (Image_Access.Bottom). If Last precedes First,
-- this is a no-op.
procedure Remove
(The_Image : Image_Handle; First : Point; Last : Point);
-- Returns the earliest starting point of all of the underlines
-- that enclose P. Could return Null_Point if none.
function Enclosing_Start
(The_Image : Image_Handle; P : Point) return Point;
-- Enables instantiator to process underlines traversing forwards
-- or backwards in the image. From indicates the point in the image
-- where the traversal is to start and is included in the search.
-- If the Skip_Rest out parameter is True, subsequent searching is
-- terminated. The user can pass information needed by Process_
-- Underline in the User_Information limited private type.
generic
type User_Information is limited private;
with procedure Process_Underline
(U : Underline;
User_Data : in out User_Information;
Skip_Rest : out Boolean);
procedure Process_Underlines (The_Image : Image_Handle;
From : Point;
Forwards : Boolean;
User_Data : in out User_Information);
end Underline_Manager;
end Editor_Interface;with System;
with Diana;
package Error_Messages is
type Errors is private;
type Annotation is private;
type Annotations is private;
type Annotation_Id is new Natural;
type Severity is (Note, Warning, Error, Internal_Error, Exception_Handled);
function Append (Prefix : Errors;
Kind : Severity;
Tree_1 : Diana.Tree;
Message : String;
Tree_2 : Diana.Tree;
Heap : System.Segment;
Tree_1a : Diana.Tree := Diana.Empty;
Tree_2a : Diana.Tree := Diana.Empty) return Errors;
function Kind (Result : Errors) return Severity;
function Tree_1 (Result : Errors) return Diana.Tree;
function Tree_1a (Result : Errors) return Diana.Tree;
function Message (Result : Errors) return String;
function Tree_2 (Result : Errors) return Diana.Tree;
function Tree_2a (Result : Errors) return Diana.Tree;
function Next (Result : Errors) return Errors;
function Is_Empty (Result : Errors) return Boolean;
function Empty return Errors;
-- use to build and interrogate messages when they cannot be attached to
-- a tree.
procedure Fault_Nodes (Root : Diana.Tree; Some_Errors : Errors);
-- Any tree referenced as a TREE_1 is a 'faulty node'. The procedure
-- FAULT_NODES converts the list of ERRORS from semantics and/or
-- directory-ops to a sequence of tree nodes with the error messages
-- attached to each. The sequence becomes the value of SM_FAULTY_NODES
-- (ROOT). Update access is required for ROOT. TREE_1A and TREE_2A are
-- ignored. Any annotations on the tree are removed prior to converting
-- the new error list
procedure Sm_Faulty_Nodes (Root : Diana.Tree;
Faulty_Nodes : Diana.Sequence);
procedure Remove_Faulty_Nodes (Root : Diana.Tree);
function Has_Sm_Faulty_Nodes (Root : Diana.Tree) return Boolean;
function Sm_Faulty_Nodes (Root : Diana.Tree) return Diana.Sequence;
function Sm_Annotations (Faulty_Node : Diana.Tree) return Annotations;
function Has_Sm_Annotations (Any_Node : Diana.Tree) return Boolean;
procedure Append (Any_Node : Diana.Tree; Msg : Annotation);
-- permanent semantic attributes tying messages to faulty nodes.
function Make (Kind : Severity; Text : String) return Annotation;
function Make (Kind : Severity; Text : String; Tree_2 : Diana.Tree)
return Annotation;
-- TREE_1 of each message is the faulty node it is attached to.
function Head (Msgs : Annotations) return Annotation;
function Tail (Msgs : Annotations) return Annotations;
function Not_Empty (Msgs : Annotations) return Boolean;
function Nil return Annotations;
-- Several messages can be associated with each faulty node.
-- Use these operators to move through the list of messages.
function Kind (Msg : Annotation) return Severity;
function Text (Msg : Annotation) return String;
function Tree_2 (Msg : Annotation) return Diana.Tree;
-- TREE_1 of each message is the (faulty) node it is attached to.
function Id (Msg : Annotation) return Annotation_Id;
function Has_Id (Msg : Annotation) return Boolean;
function Nil return Annotation_Id;
-- The ID of a message uniquely identifies the place within the
-- the semanticist where the message originated. It is often more
-- specific in defining the nature of the error than the text
-- portion of the message.
function Annotated_Message (Msg : Error_Messages.Errors) return String;
function Annotated_Message
(Node : Diana.Tree; Msg : Annotation) return String;
function Annotated_Node (Node : Diana.Tree) return String;
pragma Subsystem (Ada_Management);
pragma Module_Name (4, 1121);
private
type Error_Data (Length : Natural);
type Errors is access Error_Data;
pragma Segmented_Heap (Errors);
type Annotation is new Diana.Attr_List;
type Annotations is new Diana.Attr_List;
end Error_Messages;with Simple_Status;
with Calendar;
package Error_Reporting is
subtype Condition_Name is Simple_Status.Condition_Name;
subtype Condition_Class is Simple_Status.Condition_Class;
subtype Condition is Simple_Status.Condition;
Normal : constant Condition_Class := Simple_Status.Normal;
Warning : constant Condition_Class := Simple_Status.Warning;
Problem : constant Condition_Class := Simple_Status.Problem;
Fatal : constant Condition_Class := Simple_Status.Fatal;
function Create_Condition_Name (Name : String; Severity : Condition_Class)
return Condition_Name
renames Simple_Status.Create_Condition_Name;
procedure Report_Error (Caller : String;
Reason : Condition_Name;
Explanation : String);
procedure Report_Error (Reason : in out Condition);
pragma Subsystem (Miscellaneous);
pragma Module_Name (4, 812);
end Error_Reporting;with Default;
with System;
package Job_Segment is
pragma Consume_Offset (4);
function Get (For_Process : Default.Process_Id := Default.Process)
return System.Segment;
pragma Subsystem (Om_Mechanisms);
pragma Module_Name (4, 914);
end Job_Segment;with Directory;
with System;
package Limit_Operations is
pragma Subsystem (Directory);
pragma Module_Name (4, 3554);
-- Accepts a limit (as in compilation or show usage) and builds the
-- necessary data structures to make enquiries.
-- There are two items of interest, limit specifiers and contexts.
-- A limit specifier specifies how to interpret a 'context'.
-- A context is a set of directory.objects, and is interpreted as directed
-- by the limit string. For example, if the limit string is
-- <WORLDS>, all objects in the same worlds as the contexts are ok.
-- Since there can be many contexts, many worlds can be specified.
-- The valid limit strings are:
--
-- <UNITS> Exact match of context(s)
-- <SUBUNITS> Context(s) and all subunits
-- <DIRECTORY> <DIRECTORIES> Library containing the context(s)
-- <WORLDS> World containing the context(s)
-- <ALL_WORLDS> Anything
-- <ACTIVITY> Worlds in the default activity
-- are used as context. Implies
-- <WORLDS>
-- Any naming string/set. The objects specified by the
-- expression. If an activity is
-- given, it is decomposed. The
-- change limit is set to the
-- 'highest' object encountered
-- (object, library, world)
--
-- Prefixes of the limit strings are accepted
type Error_Status is
(Successful, Unknown_Limit_Specifier, Lock_Error,
Naming_Error, -- If set, name_status has further info
Other_Error);
function Is_Bad (Status : Error_Status) return Boolean;
procedure Initialize (Limit_String : String;
Context : String;
In_Heap : System.Segment;
Change_Limit : out Directory.Change_Limit;
Context_Set : out Directory.Object_Set.Set;
Status : out Error_Status;
Name_Status : out Directory.Naming.Name_Status);
-- The iterator is consumed here. As such it might have to be
-- reset after this call
procedure Initialize (Limit_String : String;
Context : in out Directory.Naming.Iterator;
In_Heap : System.Segment;
Change_Limit : out Directory.Change_Limit;
Context_Set : out Directory.Object_Set.Set;
Status : out Error_Status;
Name_Status : out Directory.Naming.Name_Status);
function Is_In_Limit
(Object : Directory.Object;
Change_Limit : Directory.Change_Limit;
Context_Set : Directory.Object_Set.Set) return Boolean;
procedure Initialize (Limit_String : String;
Context : Directory.Object;
In_Heap : System.Segment;
Change_Limit : out Directory.Change_Limit;
Context_Set : out Directory.Object_Set.Set;
Status : out Error_Status;
Name_Status : out Directory.Naming.Name_Status);
end Limit_Operations;with Action;
with Diana;
with Directory;
package Links_Implementation is
pragma Subsystem (Directory);
pragma Module_Name (4, 1717);
-- A "link-pack" is a managed object that defines a map from simple
-- Ada names to Ada library units. A "link" is one element of this
-- map. Every world in the directory system has a link-pack associated
-- with it. Although link-packs are permanent managed objects, they do not
-- have pathnames per se. They are identified by the world to which they
-- correspond. Conceptually, whenever a world is created, a link-pack is
-- created for that world, and the link pack is destroyed when the world is
-- destroyed.
-- The purpose of link-packs is to define the meaning of with-clauses in
-- Ada units. Let D be a directory and W be the innermost world containing
-- D (if D is a world, then W=D). Suppose an Ada unit in D contains a
-- context clause of the form "with XXX". If there is a unit named XXX
-- contained immediately within D, then the with-clause refers to that
-- unit. If there is no unit named XXX in D, then the link-pack for W is
-- consulted. If the link-pack maps XXX to some unit, then the with-clause
-- refers to that unit. If XXX cannot be resolved by examining D or the
-- link pack for W, then the with-clause will not semanticize.
-- This package performs none of this magic; it simply maintains the maps.
-- Semantics calls this package to query the state of the link packs to
-- implement the "meaning" of links.
subtype Link_Name is String;
-- An Ada simple name. When used in Add and Replace commands, it may
-- contain replacement wildcard characters. When used as in in-parameter
-- of other commands, it may contain the wildcard characters "@#?".
subtype Source_Name is String;
-- A directory string name. In Add and Replace commands, it may contain
-- the full complement of directory wildcard characters. When used as an
-- in-parameter of other commands, it may contain the wildcard characters
-- "@#?".
type Pack_Handle is private;
-- Generally, one needs to get one of these to look at or change a link
-- pack. A few commands are provided, however, for a quick look.
type Access_Mode is (Read, Update);
-- Multiple readers are permitted.
type Error_Status is (Successful, No_Link_Found, Invalid_World_Parameter,
Invalid_Action_Id, Lock_Error,
Pack_Not_Open, Pack2_Not_Open,
Not_Open_For_Update, Duplicate_Link_Name,
Undefined_Source_Name, Obsolete_Source,
Ill_Formed_Link_Name, Ill_Formed_Source_Name,
Link_Has_Dependents, Unsuccessful);
function Image (Status : Error_Status) return String;
-- returns a phrase describing the error indicated by the error status
-- code.
procedure Open (Pack : out Pack_Handle;
World : Diana.Tree;
Status : out Error_Status;
Mode : Access_Mode := Read;
Action_Id : Action.Id;
Max_Wait : Duration := 5.0);
procedure Open (Pack : out Pack_Handle;
World : Directory.Object;
Status : out Error_Status;
Mode : Access_Mode := Read;
Action_Id : Action.Id;
Max_Wait : Duration := 5.0);
-- Opens the link pack associated with the given World. The world may be
-- identified by its declaration, it directory object, or any Diana.Tree or
-- Directory.Object contained in the world. Simultaneous readers are
-- allowed. If an attempt is made to open for update a link pack that is
-- already open, the call will wait Max_Wait for the link pack to be
-- closed, and return Lock_Error if this time is exceeded.
-- If a command is supposed to make several changes to a link pack as the
-- result of wildcard processing, and an error is detected, the command
-- terminates without attempting to perform further changes. The partial
-- command by be undone by abandoning the action used to open the pack. If
-- the action is committed, the internal data structures will not be
-- corrupted, but may be incomplete.
-- The error status "unsuccessful" is an indication of a serious problem --
-- an unexpected bad status or exception returned from lower levels. If a
-- pack is open for update and "unsuccessful" is returned, the action used
-- to open the pack is made uncomittable.
procedure Close (Pack : Pack_Handle; Status : out Error_Status);
-- Does not commit the Action used to open the pack.
function Status (Pack : Pack_Handle) return Error_Status;
function Status (Pack : Pack_Handle) return String;
-- When an error is detected, the cause of the error is recorded in the
-- pack handle. These functions can be used to interrogate this status.
-- The string form of status returns a message that can be displayed to a
-- user. String'(Status (Pack)) is more informative than
-- Image (Error_Status'(Status (Pack))).
type Link_Kind is (Internal, External, Any);
-- A link is Internal if its source object is in the world of the link
-- pack; otherwise it is External. Any is valid only when requesting
-- links of a specified type and matches any link. Deleted is returned
function Has (Pack : Pack_Handle;
Source : Source_Name := "?";
Link : Link_Name := "@";
Kind : Link_Kind := Any) return Boolean;
-- Returns true iff the pack contains at least one link that matches the
-- Source, Link, and Kind parameters.
function Kind (Pack : Pack_Handle;
Source : Source_Name := "?";
Link : Link_Name := "@") return Link_Kind;
Deleted : constant Link_Kind := Any;
-- Returns the Kind of a link that matches the Source and Link parameters,
-- or Deleted if there is no matching link.
function Link (Pack : Pack_Handle;
Source : Source_Name;
Kind : Link_Kind := Any) return Link_Name;
function Link (Pack : Pack_Handle;
Source : Diana.Tree;
Kind : Link_Kind := Any) return Link_Name;
function Link (Pack : Pack_Handle;
Source : Directory.Object;
Kind : Link_Kind := Any) return Link_Name;
-- Given the Source name or declaration an object, returns a link name for
-- that object in the given link pack. The wildcards "@#?" may be used in
-- a source name. A null object is returned if no matching link can be
-- found or the kind parameter does not match the link.
function Source (Pack : Pack_Handle;
Link : Link_Name;
Kind : Link_Kind := Any) return Source_Name;
function Source (Pack : Pack_Handle;
Link : Link_Name;
Kind : Link_Kind := Any) return Diana.Tree;
function Source (Pack : Pack_Handle;
Link : Link_Name;
Kind : Link_Kind := Any) return Directory.Object;
-- Given a link name, returns the source name, declaration, or directory
-- object of the associated object. Wildcards can be used. The lookup is
-- very efficient when no wildcards are present. A null object is returned
-- if no matching link can be found. The Diana.Tree version returns a null
-- tree if the object has been deleted. The other entries do NOT return
-- null information in this case.
procedure Add (Pack : Pack_Handle;
Status : out Error_Status;
Source : Source_Name;
Link : Link_Name := "#");
procedure Add (Pack : Pack_Handle;
Status : out Error_Status;
Source : Directory.Object;
Link : Link_Name := "#");
-- For each Ada library unit defined by Source, a link is created in
-- the given Pack. The Source object is associated with the simple Ada
-- name given by Link. The operation fails if the specified Link_Name
-- already exists in the pack, unless the source name of the new link is
-- the same as the source name of the old link.
procedure Replace (Pack : Pack_Handle;
Status : out Error_Status;
Source : Source_Name;
Link : Link_Name := "#");
procedure Replace (Pack : Pack_Handle;
Status : out Error_Status;
Source : Directory.Object;
Link : Link_Name := "#");
-- For each Ada library unit defined by Source, a link is created in
-- the given Pack. The Source object is associated with the simple Ada
-- name given by Link. If a link of the same name already exists, it
-- is replaced by the new definition if the existing link has no
-- dependents.
procedure Delete (Pack : Pack_Handle;
Status : out Error_Status;
Source : Source_Name;
Link : Link_Name := "@";
Kind : Link_Kind := Any);
-- The links that match the Source, Link, and Kind parameters are deleted
-- form the link pack. The command fails if any of the matching links have
-- dependents.
procedure Copy (Source_Pack : Pack_Handle;
Target_Pack : Pack_Handle;
Status : out Error_Status;
Source : Source_Name := "?";
Link : Link_Name := "@";
Kind : Link_Kind := Any);
-- The links of Source_Pack that match the specified Source, Link, and Kind
-- parameters are copied into Target_Pack, which must be open for update.
-- The command fails if any of the links to be copied duplicates a
-- Link_Name in Target_Pack unless the new link is compatible with the
-- old link (see Add).
procedure Dependents (Ids : out Diana.Temp_Seq;
Pack : Pack_Handle;
Status : out Error_Status;
Source : Source_Name := "?";
Link : Link_Name := "@";
Kind : Link_Kind := Any);
-- Computes the Library Units of the world that are installed or coded
-- and makes use of any of the links specified by the Source, Link, and
-- Kind parameters. Links that have dependents cannot be deleted or
-- changed.
type Iterator is private;
procedure Init (Iter : out Iterator;
Pack : Pack_Handle;
Status : out Error_Status;
Source : Source_Name := "?";
Link : Link_Name := "@";
Kind : Link_Kind := Any);
-- Init finds all the links that match the parameters provided to it and,
-- copies information about them into a data structure stored in the job
-- temporary heap. Thus, changes made to the link-pack while an iterator
-- is in progress will not be reflected by the values returned by the
-- iterator.
procedure Next (Iter : in out Iterator);
function Link (Iter : Iterator) return Link_Name;
function Source (Iter : Iterator) return Source_Name;
function Source (Iter : Iterator) return Diana.Tree;
function Source (Iter : Iterator) return Directory.Object;
function Kind (Iter : Iterator) return Link_Kind;
function Done (Iter : Iterator) return Boolean;
function Link_Id (Pack : Pack_Handle) return Directory.Version;
-- This routine will only work on a handle which has been opened,
-- and is intended for use by 'trusted' programs only.
-- The returned version is a Link_Manager.Link_Id, and will not
-- be associated with any directory.object.
private
type Pack_Data;
type Pack_Handle is access Pack_Data;
pragma Segmented_Heap (Pack_Handle);
type Iterator_Data (Link_Name_Length, Full_Name_Length : Natural);
type Iterator is access Iterator_Data;
pragma Segmented_Heap (Iterator);
end Links_Implementation;with Diana, Activity_Implementation, Directory;
package Load_View is
function Needs_Resolution (Comp_Unit_Id : Diana.Tree) return Boolean;
-- True for spec units that are not mirror specs.
-- The comp_unit should not be a subunit.
type Resolution_Status is (Successful, Invalid_Activity,
Undefined_View, Invalid_View, Other_Error);
procedure Resolve (Comp_Unit_Id : Diana.Tree;
Result : out Diana.Tree;
Status : out Resolution_Status;
The_Activity : Activity_Implementation.Activity_Id :=
Activity_Implementation.Current);
-- Assumes that argument Needs_Resolution. Uses activity map to get
-- appropriate non-spec version of the given unit.
-- The argument should not be the id for a body or a subunit.
-- If STATUS=SUCCESSFUL, then RESULT gets a Dn_Comp_Unit node.
-- If STATUS=INVALID_VIEW, then RESULT gets a Dn_String_Literal node
-- containing the name of the non-existent unit in the load view.
-- Otherwise returns an empty tree.
function Resolve (Comp_Unit_Id : Diana.Tree; Load_View : Directory.Object)
return Diana.Tree;
-- for use if the target view is known through some means other than
-- an activity.
pragma Subsystem (Compiler_Utilities);
pragma Module_Name (4, 2910);
end Load_View;with Machine;
package Low_Level_Action is
pragma Subsystem (Om_Mechanisms, Private_Part => Closed);
pragma Module_Name (4, 916);
type Id is private;
Null_Id : constant Id;
function Get_Id
(Task_Id : Machine.Task_Id := Machine.Get_Task_Id) return Id;
function Is_In_Progress (Of_Action : Id) return Boolean;
pragma Consume_Offset (2);
type Mode is (None, Read, Update, Overwrite);
pragma Consume_Offset;
function Hash (The_Action : Id) return Integer;
pragma Consume_Offset (3);
procedure Prevent_Commit (The_Action : Id);
Commit_Prevented : exception;
-- raised if prevent_commit and then commit are called with the same action
end Low_Level_Action;with System;
package Machine is
-- machine id type and operations
type Id is new Long_Integer range 0 .. 2 ** 32 - 1;
Nil_Machine : constant Id := 0;
function Get_Id return Id;
-- get the id for current machine
pragma Suppress (Elaboration_Check, Get_Id);
-- task_id type and operations
subtype Task_Id is System.Module_Name;
Nil_Task : constant Task_Id := System.Null_Module;
function Get_Task_Id return Task_Id renames System.Current_Name;
function Is_Callable (The_Task : Task_Id) return Boolean;
pragma Suppress (Elaboration_Check, Is_Callable);
procedure Terminate_Job (The_Task : Task_Id);
pragma Suppress (Elaboration_Check, Terminate_Job);
Termination_Error : exception;
-- session_id and job_id types and operations
subtype Session_Id is Long_Integer range 0 .. 2 ** 24 - 1;
subtype Job_Id is System.Virtual_Processor_Number range 0 .. 255;
Nil_Session : constant Session_Id := 0;
Nil_Job : constant Job_Id := 0;
function Get_Job_Id (Of_Task : Task_Id) return Job_Id renames System.Get_Vp;
pragma Subsystem (Machine_Interface);
pragma Module_Name (4, 108);
end Machine;with Directory;
package Object_Class is
-- This package provides functions for getting the Directory.Class for
-- all of the pre-defined managed types as of Gamma_0. This includes
-- types which have type-specific operations defined at the
-- directory level (Ada, File) as well as those types
-- for which one must have direct visibility to the object manager
-- (devices, code segments, user/group/session).
function Ada return Directory.Class;
-- Equivalent to Directory.Ada.Get_Class (Ada_Manager.Class).
function Library return Directory.Class;
-- Equivalent to Directory.Control_Point.Get_Class (Directory_Manager.Class).
function File return Directory.Class;
-- Equivalent to Polymorphic_IO.Get_Class (File_Manager.Class).
function Tape return Directory.Class;
-- No directory level equivalent (Tape_Manager.Class).
function Terminal return Directory.Class;
-- No directory level equivalent (Terminal_Manager.Class).
function User return Directory.Class;
-- No directory level equivalent (User.Class).
function Group return Directory.Class;
-- No directory level equivalent (User.Group.Class).
function Session return Directory.Class;
-- No directory level equivalent (User.Session.Class).
function Code_Segment return Directory.Class;
-- No directory level equivalent (Code_Segment_Manager.Class).
function Link return Directory.Class;
-- No directory level equivalent (Link_Manager.Class).
function Null_Device return Directory.Class;
-- No directory level equivalent (Null_Device_Manager.Class).
function Pipe return Directory.Class;
-- No directory level equivalent (Pipe_Manager.Class).
function Ddb return Directory.Class;
-- No directory level equivalent (Dependency_Database_Manager.Class).
function Archived_Code return Directory.Class;
-- No directory level equivalent (Code_Db_Manager.Class).
pragma Subsystem (Directory);
pragma Module_Name (4, 1711);
end Object_Class;with Directory;
package Object_Subclass is
-- Parent class is Nil.
function Nil_Subclass return Directory.Subclass renames Directory.Nil;
function Unknown_Subclass return Directory.Subclass;
-- Parent class is Library.
function Combined_Subsystem_Subclass -- COMB_SS
return Directory.Subclass;
function Combined_View_Subclass -- COMB_VIEW
return Directory.Subclass;
function Directory_Subclass -- DIRECTORY
return Directory.Subclass;
function Load_View_Subclass -- LOAD_VIEW
return Directory.Subclass;
function Mailbox_Subclass -- MAILBOX
return Directory.Subclass;
function Spec_Load_Subsystem_Subclass -- SPEC_LOAD
return Directory.Subclass;
function Spec_View_Subclass -- SPEC_VIEW
return Directory.Subclass;
function Subsystem_Subclass -- SUBSYSTEM
return Directory.Subclass;
function World_Subclass -- WORLD
return Directory.Subclass;
-- Parent class is Ada.
function Alternative_List_Subclass -- ALT_LIST
return Directory.Subclass;
function Compilation_Unit_Subclass -- COMP_UNIT
return Directory.Subclass;
function Context_List_Subclass -- CONTEXT
return Directory.Subclass;
function Declaration_List_Subclass -- DECL_LIST
return Directory.Subclass;
function Function_Body_Subclass -- FUNC_BODY
return Directory.Subclass;
function Function_Instantiation_Subclass -- FUNC_INST
return Directory.Subclass;
function Function_Rename_Subclass -- FUNC_REN
return Directory.Subclass;
function Function_Spec_Subclass -- FUNC_SPEC
return Directory.Subclass;
function Generic_Function_Subclass -- GEN_FUNC
return Directory.Subclass;
function Generic_Package_Subclass -- GEN_PACK
return Directory.Subclass;
function Generic_Parameter_List_Subclass -- GEN_PARAM
return Directory.Subclass;
function Generic_Procedure_Subclass -- GEN_PROC
return Directory.Subclass;
function Loaded_Function_Spec_Subclass -- LOAD_FUNC
return Directory.Subclass;
function Loaded_Procedure_Spec_Subclass -- LOAD_PROC
return Directory.Subclass;
function Main_Function_Spec_Subclass -- MAIN_FUNC
return Directory.Subclass;
function Main_Function_Body_Subclass -- MAIN_BODY
return Directory.Subclass;
function Main_Procedure_Spec_Subclass -- MAIN_PROC
return Directory.Subclass;
function Main_Procedure_Body_Subclass -- MAIN_BODY
return Directory.Subclass;
function Nonterminal_Subclass -- INSERTION
return Directory.Subclass;
function Package_Body_Subclass -- PACK_BODY
return Directory.Subclass;
function Package_Instantiation_Subclass -- PACK_INST
return Directory.Subclass;
function Package_Rename_Subclass -- PACK_REN
return Directory.Subclass;
function Package_Spec_Subclass -- PACK_SPEC
return Directory.Subclass;
function Pragma_List_Subclass -- PRAGMA
return Directory.Subclass;
function Procedure_Body_Subclass -- PROC_BODY
return Directory.Subclass;
function Procedure_Instantiation_Subclass -- PROC_INST
return Directory.Subclass;
function Procedure_Rename_Subclass -- PROC_REN
return Directory.Subclass;
function Procedure_Spec_Subclass -- PROC_SPEC
return Directory.Subclass;
function Statement_List_Subclass -- STATEMENT
return Directory.Subclass;
function Subprogram_Body_Subclass -- SUBP_BODY
return Directory.Subclass;
function Subprogram_Instantiation_Subclass -- SUBP_INST
return Directory.Subclass;
function Subprogram_Rename_Subclass -- SUBP_REN
return Directory.Subclass;
function Subprogram_Spec_Subclass -- SUBP_SPEC
return Directory.Subclass;
function Task_Body_Subclass -- TASK_BODY
return Directory.Subclass;
function Unrecognizable_Function_Spec_Subclass -- ????_FUNC
return Directory.Subclass;
function Unrecognizable_Generic_Subclass -- ????_GEN
return Directory.Subclass;
function Unrecognizable_Package_Spec_Subclass -- ????_PACK
return Directory.Subclass;
function Unrecognizable_Procedure_Spec_Subclass -- ????_PROC
return Directory.Subclass;
function Unrecognizable_Subprogram_Spec_Subclass -- ????_SUBP
return Directory.Subclass;
function Unrecognizable_Subclass -- ????
return Directory.Subclass;
-- Parent class is File.
function Activity_Subclass -- ACTIVITY
return Directory.Subclass;
function Binary_Subclass -- BINARY
return Directory.Subclass;
function Byte_Aligned_Subclass -- BYTE
return Directory.Subclass;
function Cmvc_Database_Subclass -- CMVC_DB
return Directory.Subclass;
function Code_Database_Subclass -- CODE_DB
return Directory.Subclass;
function Compatibility_Database_Subclass -- COMPAT_DB
return Directory.Subclass;
function Dictionary_Subclass -- DICTIONRY
return Directory.Subclass;
function Incoming_Mail_Message_Subclass -- MSG_IN
return Directory.Subclass;
function Log_Subclass -- LOG
return Directory.Subclass;
function Mail_Subclass -- MAIL
return Directory.Subclass;
function Mail_Database_Subclass -- MAIL_DB
return Directory.Subclass;
function Object_Set_Subclass -- OBJECTS
return Directory.Subclass;
function Outgoing_Mail_Message_Subclass -- MSG_OUT
return Directory.Subclass;
function Pure_Element_File_Map_Subclass -- FILE_MAP
return Directory.Subclass;
function Postscript_Subclass -- PS
return Directory.Subclass;
function Search_List_Subclass -- SEARCH
return Directory.Subclass;
function Switch_Definition_Subclass -- SWTCH_DEF
return Directory.Subclass;
function Switch_Subclass -- SWITCH
return Directory.Subclass;
function Temporary_Subclass -- TEMP
return Directory.Subclass;
function Text_Subclass -- TEXT
return Directory.Subclass;
-- Some newer subclasses which should be mixed with the above.
function Document_Database_Subclass return Directory.Subclass;
function Configuration_Subclass return Directory.Subclass;
function Venture_Subclass return Directory.Subclass;
function Work_Order_Subclass return Directory.Subclass;
function Work_Order_List_Subclass return Directory.Subclass;
-- Newer yet subclasses
function System_View_Subclass -- SYSTEM_VIEW
return Directory.Subclass;
function System_Subsystem_Subclass -- SYSTEM
return Directory.Subclass;
--
-- Still newer yet subclasses (for CDF)
function Object_Code_Subclass -- OBJ_CODE
return Directory.Subclass;
function Executable_Code_Subclass -- EXE_CODE
return Directory.Subclass;
-- cmvc access_control file
function Cmvc_Access_Subclass return Directory.Subclass; -- CMVC_ACC
-- design facility element cache
function Element_Cache_Subclass return Directory.Subclass; -- ELEMENTS
function Design_Info_Subclass return Directory.Subclass; -- DESIGN
function Markup_Subclass return Directory.Subclass; -- MARKUP
--------------------------------------------------------------------------
pragma Consume_Offset (4);
--------------------------------------------------------------------------
type Iterator is array (Integer range <>) of Directory.Subclass;
function Defined_Subclasses
(For_Classes : String := "<ALL CLASSES>") return Iterator;
-- Returns an array of the defined subclasses of the specified
-- classes. The classes are specified by a list of the Class images
-- separated by spaces
function Maximum_Subclass (For_Classes : String := "<ALL CLASSES>")
return Directory.Subclass;
function Minimum_Subclass (For_Classes : String := "<ALL CLASSES>")
return Directory.Subclass;
-- Returns the maximum/minimum subclass value for the set of classes
-- specified.
function Diagram_Subclass return Directory.Subclass; -- DIAGRAM
pragma Subsystem (Directory);
pragma Module_Name (4, 1723);
end Object_Subclass;package Product_Authorization is
procedure Register (Product_Name : String := ">>Product Name<<";
Authorization_Code : String := "";
Expiration_Date : String := "");
-- Register a product as being available on this machine.
-- Appropriate settings for the parameters will be provided
-- by Rational customer personnel. The default value for
-- Expiration_Date is never.
function Is_Registered
(Product_Name : String := ">>Product Name<<") return Boolean;
-- Returns True iff the product has been correctly registered and has
-- not expired.
-- Moderately expensive. Should be cached if frequently referenced.
procedure Show_Registration;
-- Prints a summary of the authorized products for this machine.
pragma Subsystem (Tools);
pragma Module_Name (4, 3565);
end Product_Authorization;with Diana;
package Semantic_Attributes is
function Has_Sm_Back_Link (Node : Diana.Tree) return Boolean;
function Sm_Back_Link (Node : Diana.Tree) return Diana.Tree;
procedure Sm_Back_Link (Node : Diana.Tree; Back_Link : Diana.Tree);
procedure Sm_Applied_Pragmas (Def_Id : Diana.Tree;
Applied_Pragmas : Diana.Sequence);
procedure Add_Applied_Pragma (Def_Id : Diana.Tree;
Applied_Pragma : Diana.Tree);
function Sm_Applied_Pragmas (Def_Id : Diana.Tree) return Diana.Sequence;
function Has_Sm_Applied_Pragmas (Def_Id : Diana.Tree) return Boolean;
procedure Sm_User_Pre_Elab_Key
(Package_Id : Diana.Tree; User_Pre_Elab_Key : Integer);
function Sm_User_Pre_Elab_Key (Package_Id : Diana.Tree) return Integer;
function Has_Sm_User_Pre_Elab_Key (Package_Id : Diana.Tree) return Boolean;
procedure Sm_User_Vpid (Unit_Id : Diana.Tree; User_Vpid : Integer);
function Sm_User_Vpid (Unit_Id : Diana.Tree) return Integer;
function Has_Sm_User_Vpid (Unit_Id : Diana.Tree) return Boolean;
procedure Sm_User_Seg_Num (Unit_Id : Diana.Tree; User_Seg_Num : Integer);
function Sm_User_Seg_Num (Unit_Id : Diana.Tree) return Integer;
function Has_Sm_User_Seg_Num (Unit_Id : Diana.Tree) return Boolean;
procedure Sm_User_Offset (Id : Diana.Tree; User_Offset : Integer);
function Sm_User_Offset (Id : Diana.Tree) return Integer;
function Has_Sm_User_Offset (Id : Diana.Tree) return Boolean;
procedure Sm_Virtual_Processor_Number
(Tsk : Diana.Tree; Virtual_Processor_Number : Integer);
function Sm_Virtual_Processor_Number (Tsk : Diana.Tree) return Integer;
function Has_Sm_Virtual_Processor_Number (Tsk : Diana.Tree) return Boolean;
procedure Sm_Utility_Subprogram (Typ : Diana.Tree;
Utility_Subprogram : Diana.Tree);
function Sm_Utility_Subprogram (Typ : Diana.Tree) return Diana.Tree;
function Has_Sm_Utility_Subprogram (Typ : Diana.Tree) return Boolean;
procedure Sm_Subsystem_Name (Unit_Id : Diana.Tree;
Subsystem_Name : Diana.Tree);
function Sm_Subsystem_Name (Unit_Id : Diana.Tree) return Diana.Tree;
function Has_Sm_Subsystem_Name (Unit_Id : Diana.Tree) return Boolean;
procedure Sm_Enable_Runtime_Privacy
(Typ : Diana.Tree; Enable_Runtime_Privacy : Boolean);
function Sm_Enable_Runtime_Privacy (Typ : Diana.Tree) return Boolean;
function Has_Sm_Enable_Runtime_Privacy (Typ : Diana.Tree) return Boolean;
procedure Sm_Subsystem_Interface
(Unit_Id : Diana.Tree; Subsystem_Interface : Boolean);
function Sm_Subsystem_Interface (Unit_Id : Diana.Tree) return Boolean;
function Has_Sm_Subsystem_Interface (Unit_Id : Diana.Tree) return Boolean;
procedure Sm_Interface_Private
(Unit_Id : Diana.Tree; Interface_Private : Boolean);
function Sm_Interface_Private (Unit_Id : Diana.Tree) return Boolean;
function Has_Sm_Interface_Private (Unit_Id : Diana.Tree) return Boolean;
procedure Sm_Changed_To_Rename_Init
(Exp : Diana.Tree; Changed_To_Rename_Init : Boolean);
function Sm_Changed_To_Rename_Init (Exp : Diana.Tree) return Boolean;
function Has_Sm_Changed_To_Rename_Init (Exp : Diana.Tree) return Boolean;
procedure Sm_Heap (Allocator : Diana.Tree; Heap : Diana.Tree);
function Sm_Heap (Allocator : Diana.Tree) return Diana.Tree;
function Has_Sm_Heap (Allocator : Diana.Tree) return Boolean;
procedure Sm_In_Segmented_Heap
(Type_Spec : Diana.Tree; In_Segmented_Heap : Boolean);
function Sm_In_Segmented_Heap (Type_Spec : Diana.Tree) return Boolean;
function Has_Sm_In_Segmented_Heap (Type_Spec : Diana.Tree) return Boolean;
function Has_Sm_Hidden_Op (Type_Spec : Diana.Tree) return Boolean;
function Sm_Hidden_Op (Type_Spec : Diana.Tree) return Diana.Tree;
procedure Sm_Hidden_Op (Type_Spec : Diana.Tree; Ops : Diana.Tree);
function Has_Sm_Parent_Type (Type_Spec : Diana.Tree) return Boolean;
function Sm_Parent_Type (Type_Spec : Diana.Tree) return Diana.Tree;
procedure Sm_Parent_Type (Type_Spec : Diana.Tree; Ops : Diana.Tree);
function Has_Sm_Body_Ops (Type_Spec : Diana.Tree) return Boolean;
function Sm_Body_Ops (Type_Spec : Diana.Tree) return Diana.Sequence;
procedure Sm_Body_Ops (Type_Spec : Diana.Tree; Ops : Diana.Sequence);
function Has_Sm_First_Named_Subtype_Id
(Derived_Node : Diana.Tree) return Boolean;
function Sm_First_Named_Subtype_Id
(Derived_Node : Diana.Tree) return Diana.Tree;
procedure Sm_First_Named_Subtype_Id
(Derived_Node : Diana.Tree; Type_Id : Diana.Tree);
procedure Sm_Parent (T : Diana.Tree; V : Diana.Tree);
function Sm_Parent (T : Diana.Tree) return Diana.Tree;
function Has_Sm_Parent (T : Diana.Tree) return Boolean;
procedure Sm_Forward (T : Diana.Tree; V : Diana.Tree);
function Sm_Forward (T : Diana.Tree) return Diana.Tree;
function Has_Sm_Forward (T : Diana.Tree) return Boolean;
procedure Sm_Expanded_Body (T : Diana.Tree; V : Diana.Tree);
function Sm_Expanded_Body (T : Diana.Tree) return Diana.Tree;
function Has_Sm_Expanded_Body (T : Diana.Tree) return Boolean;
procedure Sm_Used_Ids (T : Diana.Tree; V : Diana.Sequence);
function Sm_Used_Ids (T : Diana.Tree) return Diana.Sequence;
function Has_Sm_Used_Ids (T : Diana.Tree) return Boolean;
procedure Sm_Default_Ids (T : Diana.Tree; V : Diana.Sequence);
function Sm_Default_Ids (T : Diana.Tree) return Diana.Sequence;
function Has_Sm_Default_Ids (T : Diana.Tree) return Boolean;
procedure Sm_Anonymous_Id (T : Diana.Tree; V : Diana.Tree);
function Sm_Anonymous_Id (T : Diana.Tree) return Diana.Tree;
function Has_Sm_Anonymous_Id (T : Diana.Tree) return Boolean;
procedure Sm_Private_Type_Id (T : Diana.Tree; V : Diana.Tree);
function Sm_Private_Type_Id (T : Diana.Tree) return Diana.Tree;
function Has_Sm_Private_Type_Id (T : Diana.Tree) return Boolean;
procedure Sm_Ops (T : Diana.Tree; V : Diana.Sequence);
function Sm_Ops (T : Diana.Tree) return Diana.Sequence;
function Has_Sm_Ops (T : Diana.Tree) return Boolean;
procedure Sm_Parent_Op (T : Diana.Tree; V : Diana.Tree);
function Sm_Parent_Op (T : Diana.Tree) return Diana.Tree;
function Has_Sm_Parent_Op (T : Diana.Tree) return Boolean;
procedure Sm_Variants (T : Diana.Tree; V : Diana.Sequence);
function Sm_Variants (T : Diana.Tree) return Diana.Sequence;
function Has_Sm_Variants (T : Diana.Tree) return Boolean;
procedure Sm_Agg_Fields (T : Diana.Tree; V : Diana.Sequence);
function Sm_Agg_Fields (T : Diana.Tree) return Diana.Sequence;
function Has_Sm_Agg_Fields (T : Diana.Tree) return Boolean;
procedure Sm_Range (T : Diana.Tree; V : Diana.Tree);
function Sm_Range (T : Diana.Tree) return Diana.Tree;
function Has_Sm_Range (T : Diana.Tree) return Boolean;
procedure Sm_Priority (T : Diana.Tree; V : Integer);
function Sm_Priority (T : Diana.Tree) return Integer;
function Has_Sm_Priority (T : Diana.Tree) return Boolean;
procedure Sm_Discrim_Ref (T : Diana.Tree; V : Boolean);
function Sm_Discrim_Ref (T : Diana.Tree) return Boolean;
function Has_Sm_Discrim_Ref (T : Diana.Tree) return Boolean;
procedure Sm_Dynamic_Agg (T : Diana.Tree; V : Boolean);
function Sm_Dynamic_Agg (T : Diana.Tree) return Boolean;
function Has_Sm_Dynamic_Agg (T : Diana.Tree) return Boolean;
procedure Sm_Has_Rep_Spec (T : Diana.Tree; V : Boolean);
function Sm_Has_Rep_Spec (T : Diana.Tree) return Boolean;
function Has_Sm_Has_Rep_Spec (T : Diana.Tree) return Boolean;
procedure Sm_Scale (T : Diana.Tree; V : Integer);
function Sm_Scale (T : Diana.Tree) return Integer;
function Has_Sm_Scale (T : Diana.Tree) return Boolean;
procedure Sm_Must_Be_Constrained (T : Diana.Tree; V : Boolean);
function Sm_Must_Be_Constrained (T : Diana.Tree) return Boolean;
function Has_Sm_Must_Be_Constrained (T : Diana.Tree) return Boolean;
procedure Sm_Instantiators (T : Diana.Tree; V : Diana.Sequence);
function Sm_Instantiators (T : Diana.Tree) return Diana.Sequence;
function Has_Sm_Instantiators (T : Diana.Tree) return Boolean;
type Syntax_Error_Level is
(No_Syntax_Errors, Minor_Syntax_Errors,
Major_Syntax_Errors, Catastrophic_Syntax_Errors);
procedure Lx_Error_Level (T : Diana.Tree; V : Syntax_Error_Level);
function Lx_Error_Level (T : Diana.Tree) return Syntax_Error_Level;
function Has_Lx_Error_Level (T : Diana.Tree) return Boolean;
procedure Sm_Hidden_Ops (T : Diana.Tree; V : Diana.Sequence);
function Sm_Hidden_Ops (T : Diana.Tree) return Diana.Sequence;
function Has_Sm_Hidden_Ops (T : Diana.Tree) return Boolean;
procedure Sm_Read_Only (T : Diana.Tree; V : Boolean);
function Sm_Read_Only (T : Diana.Tree) return Boolean;
function Has_Sm_Read_Only (T : Diana.Tree) return Boolean;
procedure Sm_Original_Node (T : Diana.Tree; V : Diana.Tree);
function Sm_Original_Node (T : Diana.Tree) return Diana.Tree;
function Has_Sm_Original_Node (T : Diana.Tree) return Boolean;
procedure Sm_Predefined (T : Diana.Tree; V : Boolean);
function Sm_Predefined (T : Diana.Tree) return Boolean;
function Has_Sm_Predefined (T : Diana.Tree) return Boolean;
procedure Sm_Static_Scope (T : Diana.Tree; V : Boolean);
function Sm_Static_Scope (T : Diana.Tree) return Boolean;
function Has_Sm_Static_Scope (T : Diana.Tree) return Boolean;
procedure Sm_Generic_Procedure (T : Diana.Tree; V : Boolean);
function Sm_Generic_Procedure (T : Diana.Tree) return Boolean;
function Has_Sm_Generic_Procedure (T : Diana.Tree) return Boolean;
-- Identifies the kind of spec associated with a stubbed generic: if
-- this attribute is not present on the Dn_Stub, the associated spec is
-- a package_spec; if present on the Dn_Stub and TRUE, the separate
-- spec is a procedure; if present on the Dn_Stub and FALSE, the
-- separate spec is a function.
procedure Sm_Decl_Number (T : Diana.Tree; I : Diana.Decl_Number);
function Sm_Decl_Number (T : Diana.Tree) return Diana.Decl_Number;
function Has_Sm_Decl_Number (T : Diana.Tree) return Boolean;
function Make_Sm_Decl_Number_Mask
(T : Diana.Tree) return Diana.Decl_Number_Mask;
function Sm_Decl_Number_Mask (T : Diana.Tree) return Diana.Decl_Number_Mask;
function Has_Sm_Decl_Number_Mask (T : Diana.Tree) return Boolean;
procedure Decl_Number (T : Diana.Tree; I : Diana.Declaration_Number);
function Decl_Number (T : Diana.Tree) return Diana.Declaration_Number;
function Has_Decl_Number (T : Diana.Tree) return Boolean;
function Make_Decl_Number_Mask (T : Diana.Tree; Size : Natural)
return Diana.Declaration_Number_Mask;
function Decl_Number_Mask (T : Diana.Tree)
return Diana.Declaration_Number_Mask;
function Has_Decl_Number_Mask (T : Diana.Tree) return Boolean;
procedure Copy_Decl_Number_Map (From : Diana.Tree; To : Diana.Tree);
procedure Sm_Operator (Def_Op : Diana.Tree; Op : Diana.Operator);
function Sm_Operator (Def_Op : Diana.Tree) return Diana.Operator;
function Has_Sm_Operator (Def_Op : Diana.Tree) return Boolean;
pragma Subsystem (Ada_Management);
pragma Module_Name (4, 1109);
end Semantic_Attributes;generic
with procedure Snapshot_Starting;
Client_Name : String;
-- Client_Name is used to report errors (if any) reflected back from
-- calling Snapshot_Starting, including timeout.
package Snapshot_Notification is
procedure Set_Timeout (Interval : Duration := 5.0);
-- Snapshot will be held up at most Interval.
-- An Error_Log entry is made if more than Interval is required.
-- Timeout will never exceed 60.0 and should not be set above the default.
pragma Module_Name (4, 3928);
pragma Subsystem (Os_Commands);
end Snapshot_Notification;with Action;
with Directory;
with Polymorphic_Io;
package Switch_Implementation is
pragma Subsystem (Directory, Private_Part => Closed);
pragma Module_Name (4, 1704);
subtype File is Polymorphic_Io.Version;
subtype Handle is Polymorphic_Io.Handle;
function Default_File return File;
subtype Switch_Class_Name is String;
-- an Ada simple name; Each definer of a class must use a unique
-- class name. e.g. "Semantics", "Cg"
subtype Switch_Value_Name is String;
-- an Ada simple name; The name of each switch defined by a given
-- class must be distinct from other switches of the same class.
-- "Ignore_minor_Errors", "Enable_Environment_Debugger"
subtype Switch_Composite_Name is String;
-- an expanded Ada name whose prefix is a Switch_Class_Name and
-- whose simple name is a Switch_Value_Name. (In most cases, the
-- Switch_Class_Name can be omitted if the Switch_Value_Name is
-- unique.)
-- "Semantics.Ignore_Minor_Errors", "Cg.Enable_Envirnonment_Debugger"
subtype Switch_Value_Image is String;
-- Class/Switch dependent. Parentheses and string quotes must be
-- balanced within an image. The symbols "=>" and "," may appear in the
-- image only if nested within parentheses or string quotes.
Ill_Formed_Switch_Value_Image : exception;
Switch_Type_Violation : exception;
Undefined_Switch_Name : exception;
Ambiguous_Switch_Name : exception;
-- raised by image processors when they find a problem.
Switch_Category_Violation : exception;
-- raised on an attempt to set a switch of one category into a file
-- created for another category.
type Value_Kind is (Boolean_Value, Integer_Value, Text_Value, Generic_Value,
Boolean_Array_Value, Generic_Array_Value);
pragma Consume_Offset (7);
type Iterator is limited private;
procedure Initiate (Iter : out Iterator;
Switches : File;
Name : Switch_Composite_Name := "@.@";
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Directory.Default_Wait);
-- Iterate over all classes/switches in a switch file of a specified
-- form. The switch file is opened for read during the iteration.
procedure Initiate (Iter : out Iterator;
Name : Switch_Composite_Name := "@.@");
-- Iterate over all registered classes/switches of a specified form
procedure Initiate (Iter : out Iterator;
Category : Character;
Name : Switch_Composite_Name := "@.@");
-- Iterate over all switches of a given class and form.
procedure Finish (Iter : in out Iterator);
-- Closes switch file; frees iteration data structures. Should be
-- called by all users at the end of the iteration
function Name (Iter : Iterator) return Switch_Composite_Name;
function Image (Iter : Iterator) return Switch_Value_Image;
function Type_Name (Iter : Iterator) return String;
function Hidden (Iter : Iterator) return Boolean;
function Category (Iter : Iterator) return Character;
function Kind (Iter : Iterator) return Value_Kind;
function Value (Iter : Iterator) return Boolean;
function Value (Iter : Iterator) return Integer;
function Value (Iter : Iterator) return String;
function Done (Iter : Iterator) return Boolean;
procedure Next (Iter : in out Iterator);
-- These subprograms allow clients to determine the nature of defined
-- switches and their values.
function Is_Defined (Name : Switch_Composite_Name) return Boolean;
-- Determines if the given switch name is defined in the system.
function Type_Name (Name : Switch_Composite_Name) return String;
-- returns the name of the type of the given switch'es values.
function Kind (Name : Switch_Composite_Name) return Value_Kind;
-- returns the type class of the given switch
function Diagnosis
(Name : Switch_Composite_Name; Image : Switch_Value_Image)
return String;
-- Analyzes the given image as a possible legal value for the given
-- switch. returns the null string if it is a valid value, otherwise
-- it returns the text of a message explaining why the diagnosis failed.
function Is_Default
(Name : Switch_Composite_Name; Image : Switch_Value_Image)
return Boolean;
-- Returns true if the given Image is the image of the default value
-- for the named switch.
function Default_Image (Name : Switch_Composite_Name)
return Switch_Value_Image;
function Canonical_Image (Name : Switch_Composite_Name;
Image : Switch_Value_Image)
return Switch_Value_Image;
-- Returns the canonical image for given image of the given switch
-- name. Raises Ill_Formed_Switch_Value_Image if the given image is
-- not well formed.
function Canonical_Name (Name : Switch_Value_Name)
return Switch_Composite_Name;
-- Given the simple name for a switch, retruns the full (composite)
-- name. Raises Undefined and ambiguous name when appropriate.
function Help (Name : Switch_Composite_Name;
Image : Switch_Value_Image := "") return String;
-- returns a description of the purpose, usage, and values of the switch.
function Is_Switch_File
(Switches : File;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Directory.Default_Wait) return Boolean;
function Is_Switch_File (Switches : Handle) return Boolean;
-- Returns true if the given file/handle is that for a switch file. The
-- nil file is declared a switch file.
-- Given a Switch file and the name of a switch, the following
-- subprograms Set the switch value from the value's image, retrieve
-- the kind, image or value of the switch. Values are available only
-- for Boolean, Integer, and String types;
function Has (Switches : File;
Name : Switch_Composite_Name;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Directory.Default_Wait) return Boolean;
function Has (Switches : Handle; Name : Switch_Composite_Name)
return Boolean;
procedure Set (Switches : File;
Name : Switch_Composite_Name;
Image : Switch_Value_Image;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Directory.Default_Wait);
procedure Set (Switches : Handle;
Name : Switch_Composite_Name;
Image : Switch_Value_Image);
function Image (Switches : File;
Name : Switch_Composite_Name;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Directory.Default_Wait)
return Switch_Value_Image;
function Image (Switches : Handle; Name : Switch_Composite_Name)
return Switch_Value_Image;
function Value (Switches : File;
Name : Switch_Composite_Name;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Directory.Default_Wait)
return Boolean;
function Value (Switches : Handle; Name : Switch_Composite_Name)
return Boolean;
function Value (Switches : File;
Name : Switch_Composite_Name;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Directory.Default_Wait)
return Integer;
function Value (Switches : Handle; Name : Switch_Composite_Name)
return Integer;
function Value
(Switches : File;
Name : Switch_Composite_Name;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Directory.Default_Wait) return String;
function Value
(Switches : Handle; Name : Switch_Composite_Name) return String;
-- Switch file manipulations
procedure Merge (Into : Handle;
From : Handle;
Component : Switch_Composite_Name := "@.@");
-- Copy the switch values that match the given Component specification
-- from the From file into the Into file.
function Hidden (Name : Switch_Composite_Name) return Boolean;
-- Some switches are hidden from public view
function Category (Name : Switch_Composite_Name) return Character;
-- returns the category of the named switch
function Category (Switches : Handle) return Character;
function Category (Switches : File;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Directory.Default_Wait)
return Character;
-- Returns the category of the given file.
procedure Create (Name : Directory.Naming.Name;
Switches : out Switch_Implementation.File;
Handle : in out Switch_Implementation.Handle;
Status : out Directory.Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Directory.Default_Wait;
Category : Character := 'L');
-- Creates a switch file of the specified category. The newly created
-- file is open for read_write access on the supplied handle.
function Canonical (S : String) return String;
-- Images and switch names are stored in a canonical form, this
-- function transforms a string to this canonical form.
end Switch_Implementation;with System;
package Universal is
pragma Subsystem (Ada_Management, Closed);
pragma Module_Name (4, 1115);
type Integer is private;
type Float is private;
-- UNIVERSAL.INTEGER operators
-- function "=" (LEFT, RIGHT: INTEGER) return BOOLEAN;
function "<" (Left, Right : Integer) return Boolean;
function "<=" (Left, Right : Integer) return Boolean;
function ">" (Left, Right : Integer) return Boolean;
function ">=" (Left, Right : Integer) return Boolean;
function "+" (Left : Integer) return Integer;
function "-" (Left : Integer) return Integer;
function "abs" (Left : Integer) return Integer;
function "+" (Left, Right : Integer) return Integer;
function "-" (Left, Right : Integer) return Integer;
function "*" (Left, Right : Integer) return Integer;
function "/" (Left, Right : Integer) return Integer;
function "rem" (Left, Right : Integer) return Integer;
function "mod" (Left, Right : Integer) return Integer;
function "**" (Left : Integer; Right : Standard.Integer) return Integer;
-- UNIVERSAL.FLOAT operators
-- function "=" (LEFT, RIGHT: FLOAT) return BOOLEAN;
function "<" (Left, Right : Float) return Boolean;
function "<=" (Left, Right : Float) return Boolean;
function ">" (Left, Right : Float) return Boolean;
function ">=" (Left, Right : Float) return Boolean;
function "+" (Left : Float) return Float;
function "-" (Left : Float) return Float;
function "abs" (Left : Float) return Float;
function "+" (Left, Right : Float) return Float;
function "-" (Left, Right : Float) return Float;
function "*" (Left, Right : Float) return Float;
function "/" (Left, Right : Float) return Float;
function "**" (Left : Float; Right : Standard.Integer) return Float;
-- additional UNIVERSAL operators
function "*" (Left : Integer; Right : Float) return Float;
function "*" (Left : Float; Right : Integer) return Float;
function "/" (Left : Float; Right : Integer) return Float;
-- constants
function Zero return Integer;
function Zero return Float;
function One return Integer;
function One return Float;
-- conversion operators
function Value (Left : Integer) return Float;
function Value (Left : Float) return Integer;
function Value (Left : Standard.Float) return Float;
function Value (Left : Standard.Integer) return Integer;
function Convert (Left : Integer) return Standard.Integer;
function Convert (Left : Float) return Standard.Float;
-- image functions
function Image (Left : Integer) return String;
function Image (Left : Float) return String;
-- type characteristics
function Integer_Tick_Last return Integer;
function Integer_Tick_First return Integer;
function Float_Tick_First return Float;
function Float_Tick_Last return Float;
function Integer_Tick_Size return Standard.Integer;
function Float_Tick_Size return Standard.Integer;
function Float_Tick_Machine_Mantissa return Standard.Integer;
-- representation munging utilities
type Bit_String is array (Positive range <>) of Boolean;
function Bits (I : Integer) return Bit_String;
-- returns a bit_string of length UNIVERSAL.INTEGER_TICK_SIZE
-- containing
-- the value of I expressed as a binary integer, right justified in
-- the bit string.
function Mantissa (F : Float) return Bit_String;
-- returns a bit_string of length UNIVERSAL.FLOAT_TICK_MACHINE_MANTISSA
-- containing the value of the mantissa of F expressed as a binary
-- fraction with the binary point assumed at the left end of the
-- string. (See note.)
function Exponent (F : Float) return Standard.Integer;
-- returns the exponent of F (See note.)
function Value (Int : Bit_String) return Integer;
-- The bit string is interpreted as a binary integer. The function
-- returns the value of that integer in the UNIVERSAL.INTEGER
-- format.
function Value (Mantissa : Bit_String) return Float;
-- The bit string is interpreted as a binary mantissa (with binary
-- point assumed at the left end of the string). The function
-- returns the value of that mantissa in the UNIVERSAL.FLOAT format.
-- Note: The following identities hold:
-- VALUE (BITS (I)) = I and VALUE (MANTISSA (F)) * 2.0 ** EXPONENT (F) = F
function Value (Left : Standard.Long_Integer) return Integer;
function Convert (Left : Integer) return Standard.Long_Integer;
function In_Range (Left, Right1, Right2 : Integer) return Boolean;
function In_Range (Left, Right1, Right2 : Float) return Boolean;
type Real is private;
-- arbitrary precision real representation
function Equal (Left, Right : Real) return Boolean;
function "<" (Left, Right : Real) return Boolean;
function "<=" (Left, Right : Real) return Boolean;
function ">" (Left, Right : Real) return Boolean;
function ">=" (Left, Right : Real) return Boolean;
function In_Range (Left, Right1, Right2 : Real) return Boolean;
function "+" (Left : Real) return Real;
function "-" (Left : Real) return Real;
function "abs" (Left : Real) return Real;
function "+" (Left, Right : Real) return Real;
function "-" (Left, Right : Real) return Real;
function "*" (Left, Right : Real) return Real;
function "/" (Left, Right : Real) return Real;
function "**" (Left : Real; Right : Standard.Integer) return Real;
function "*" (Left : Integer; Right : Real) return Real;
function "*" (Left : Real; Right : Integer) return Real;
function "/" (Left : Real; Right : Integer) return Real;
function Zero return Real;
function One return Real;
function Value (Left : Integer) return Real;
function Value (Left : Standard.Float) return Real;
function Value (Left : Float) return Real;
function Value (N, D : Integer) return Real;
function Value (N, D : String) return Real;
function Value (Left : Real) return Integer;
function Convert (Left : Real) return Standard.Float;
function Convert (Left : Real) return Float;
function Image (Left : Real) return String;
function Mantissa (F : Real) return Bit_String;
function Exponent (F : Real) return Standard.Integer;
function Value (Mantissa : Bit_String) return Real;
function Numerator (F : Real) return String;
function Denominator (F : Real) return String;
type Int is private;
-- arbitrary precision integer type
function Equal (Left, Right : Int) return Boolean;
function "<" (Left, Right : Int) return Boolean;
function "<=" (Left, Right : Int) return Boolean;
function ">" (Left, Right : Int) return Boolean;
function ">=" (Left, Right : Int) return Boolean;
function In_Range (Left, Right1, Right2 : Int) return Boolean;
function "+" (Left : Int) return Int;
function "-" (Left : Int) return Int;
function "abs" (Left : Int) return Int;
function "+" (Left, Right : Int) return Int;
function "-" (Left, Right : Int) return Int;
function "*" (Left, Right : Int) return Int;
function "/" (Left, Right : Int) return Int;
function "**" (Left : Int; Right : Standard.Integer) return Int;
function "*" (Left : Integer; Right : Int) return Int;
function "*" (Left : Int; Right : Integer) return Int;
function "/" (Left : Int; Right : Integer) return Int;
function Zero return Int;
function One return Int;
function Value (Left : Integer) return Int;
function Value (Left : Int) return Integer;
function Image (Left : Int) return String;
function Value (S : String) return Int;
function Image (Left : Int) return System.Byte_String;
function Value (S : System.Byte_String) return Int;
function Image (Left : Real) return System.Byte_String;
function Value (S : System.Byte_String) return Real;
end Universal;package Work_Order_Errors is
pragma Subsystem (Cmvc);
pragma Module_Name (4, 3785);
pragma Bias_Key (9);
No_Default_Value : exception;
Data_Present : exception;
Mismatched_Vector_Operation : exception;
Type_Mismatch : exception;
subtype Status is Natural range 0 .. 127;
function Is_Bad (Error : Status) return Boolean;
function Is_Warning (Error : Status) return Boolean;
function Is_Good (Error : Status) return Boolean;
function Message (Error : Status) return String;
Bad_Work_Order_Status : exception;
Warning_Work_Order_Status : exception;
procedure Check (Error : Status; Flag_Warnings : Boolean := False);
-- New constants will be added as the need arises.
subtype Bad_Status is Status;
subtype Warning_Status is Status;
subtype Good_Status is Status;
Nil : constant Good_Status := 0;
Successful : constant Good_Status := 0;
Reorganized_Read_Only_Venture : constant Bad_Status := 1;
Venture_Handle_Not_Writable : constant Bad_Status := 2;
Venture_Field_Not_Found : constant Warning_Status := 3;
Venture_Field_Already_Exists : constant Bad_Status := 4;
Venture_Field_Type_Mismatch : constant Bad_Status := 5;
Venture_Field_Vector_Mismatch : constant Bad_Status := 6;
No_Default_Field_Value : constant Bad_Status := 7;
Venture_Handle_Not_Open : constant Bad_Status := 8;
Null_Venture_Field_Handle : constant Bad_Status := 9;
Reorganized_Read_Only_Work_Order : constant Bad_Status := 10;
Order_Handle_Not_Writable : constant Bad_Status := 11;
Order_Field_Not_Found : constant Warning_Status := 12;
Order_Field_Already_Exists : constant Bad_Status := 13;
Order_Field_Data_Present : constant Bad_Status := 14;
Order_Field_Vector_Mismatch : constant Bad_Status := 15;
Order_Field_Type_Mismatch : constant Bad_Status := 16;
Null_Order_Field_Handle : constant Bad_Status := 17;
Order_Handle_Not_Open : constant Bad_Status := 18;
Order_Belongs_To_A_Different_Venture : constant Bad_Status := 19;
Directory_Lock_Error : constant Bad_Status := 20;
Directory_Semantic_Error : constant Bad_Status := 21;
Directory_Code_Generation_Error : constant Bad_Status := 22;
Directory_Obsolescence_Error : constant Bad_Status := 23;
Directory_Bad_Tree_Parameter : constant Bad_Status := 24;
Directory_Illegal_Operation : constant Bad_Status := 25;
Directory_Consistency_Error : constant Bad_Status := 44;
Directory_Version_Error : constant Bad_Status := 26;
Directory_Name_Error : constant Bad_Status := 27;
Directory_Access_Error : constant Bad_Status := 28;
Directory_Policy_Error : constant Bad_Status := 29;
Directory_Bad_Action : constant Bad_Status := 30;
Directory_Class_Error : constant Bad_Status := 31;
Directory_Other_Error : constant Bad_Status := 32;
Directory_Bad_Naming_Context : constant Bad_Status := 33;
Directory_Ill_Formed_Name : constant Bad_Status := 34;
Directory_Undefined_Name : constant Bad_Status := 35;
Directory_Ambiguous_Name : constant Bad_Status := 36;
Directory_No_Selection : constant Bad_Status := 37;
Directory_Cursor_Not_In_Selection : constant Bad_Status := 38;
Directory_Selections_Not_Supported : constant Bad_Status := 39;
Directory_No_Declaration : constant Bad_Status := 40;
Directory_No_Object : constant Bad_Status := 41;
Directory_No_Editor : constant Bad_Status := 42;
Directory_Naming_Unsuccessful : constant Bad_Status := 43;
Order_Set_Handle_Not_Writable : constant Bad_Status := 50;
Reorganized_Read_Only_Order_Set : constant Bad_Status := 51;
Id_Already_In_Order_Set : constant Warning_Status := 52;
Id_Not_Found_In_Order_Set : constant Warning_Status := 53;
Reorganized_Read_Only_Venture_Default : constant Bad_Status := 60;
Venture_Default_Handle_Not_Writable : constant Bad_Status := 61;
No_Venture_Default_Set : constant Warning_Status := 62;
Added_New_User : constant Good_Status := 63;
Order_User_Handle_Not_Writable : constant Bad_Status := 70;
Reorganized_Read_Only_Order_User : constant Bad_Status := 71;
Id_Already_In_Order_User : constant Warning_Status := 72;
Id_Not_Found_In_Order_User : constant Warning_Status := 73;
Set_Handle_Not_Writable : constant Bad_Status := 80;
Reorganized_Read_Only_Set : constant Bad_Status := 81;
Id_Already_In_Set : constant Bad_Status := 82;
Id_Not_Found_In_Set : constant Warning_Status := 83;
List_Handle_Not_Writable : constant Bad_Status := 90;
List_Handle_Not_Open : constant Bad_Status := 91;
List_Belongs_To_A_Different_Venture : constant Bad_Status := 92;
Assumed_Field_Default_Of_False : constant Warning_Status := 100;
Assumed_Field_Default_Of_Zero : constant Warning_Status := 101;
List_Open_With_Wrong_Action : constant Bad_Status := 102;
Real_Default_Is_Garbage : constant Warning_Status := 114;
Illegal_Field_Name : constant Bad_Status := 115;
Product_Authorization_Failure : constant Bad_Status := 116;
Order_Is_Not_Closed : constant Bad_Status := 117;
Not_Allowed_During_Traversal : constant Bad_Status := 118;
Abandoned_Action : constant Warning_Status := 119;
Cannot_Open_For_None : constant Bad_Status := 120;
Bad_User_Id : constant Bad_Status := 121;
Order_Is_Closed : constant Bad_Status := 122;
Not_A_Venture : constant Bad_Status := 123;
Not_A_Work_Order : constant Bad_Status := 124;
Not_A_Work_Order_List : constant Bad_Status := 125;
Unknown_Error : constant Bad_Status := 126;
Bad : constant Bad_Status := 127;
end Work_Order_Errors;with Action;
with Calendar;
with Default;
with Directory;
with Io;
with Machine;
with System;
with Work_Order_Errors;
package Work_Order_Implementation is
pragma Subsystem (Cmvc);
pragma Module_Name (4, 3780);
pragma Bias_Key (9);
subtype User_Id is Machine.Session_Id;
subtype Venture_Id is Directory.Object;
subtype Work_Order_Id is Directory.Object;
subtype Work_Order_List_Id is Directory.Object;
function Nil return Directory.Object renames Directory.Nil;
function Is_Nil (Id : Directory.Object) return Boolean
renames Directory.Is_Nil;
type Venture_Handle is private;
type Work_Order_Handle is private;
type Work_Order_List_Handle is private;
Null_Venture_Handle : constant Venture_Handle;
Null_Work_Order_Handle : constant Work_Order_Handle;
Null_Work_Order_List_Handle : constant Work_Order_List_Handle;
subtype Status is Work_Order_Errors.Status;
type Open_Mode is (None, Read, Update);
-- Types used in Fields.
type Venture_Field is private;
type Work_Order_Field is private;
Null_Venture_Field : constant Venture_Field;
Null_Work_Order_Field : constant Work_Order_Field;
type Field_Type_Enum is (Bool, Str, Int);
type Descriptor_Info_Record is
record
Element_Type : Field_Type_Enum; -- Elements have this type.
Is_Vector : Boolean; -- Are elements arrays?
end record;
-- A Venture is a Work Order Database created in a subsystem.
-- This subsystem can be at any level in the hierarchy
-- (see CMVC.Project_Hierarchy_Operations).
package Venture_Control is
procedure Find (Venture_Name : String;
Result : out Venture_Id;
Success : out Status);
--
-- Invoke name resolution on a string.
-- Returns bad status if the venture cannot be found.
procedure Create (Venture_Name : String;
The_Handle : out Venture_Handle;
Success : out Status;
Notes : String := "";
Storage : System.Segment := System.Null_Segment;
Action_Id : Action.Id := Action.Null_Id);
--
-- New venture will be open for Update.
procedure Open (The_Venture : Venture_Id;
The_Handle : out Venture_Handle;
Success : out Status;
Mode : Open_Mode := Read;
Storage : System.Segment := System.Null_Segment;
Action_Id : Action.Id := Action.Null_Id);
--
-- The_Venture may not be opened with mode None.
procedure Close (The_Handle : in out Venture_Handle;
Success : out Status);
--
-- The_Handle will be set to Null_Venture_Handle after closing.
function Id (The_Handle : Venture_Handle) return Venture_Id;
function Mode (The_Handle : Venture_Handle) return Open_Mode;
function Full_Name (The_Handle : Venture_Handle) return String;
-- These information functions may be used on any handle.
end Venture_Control;
package Venture_Operations is
procedure Set_Default (To : Venture_Id;
Success : out Status;
For_User : User_Id := Default.Session);
--
-- Set the appropriate session switch. To may be Nil.
procedure Get_Default (Result : out Venture_Id;
Success : out Status;
For_User : User_Id := Default.Session;
Ignore_Garbage : Boolean := True);
--
-- If Ignore_Garbage is True and the default venture no longer
-- exists, Nil will be returned instead.
function Require_Default_Venture return Boolean;
procedure Set_Require_Default_Venture
(To_Val : Boolean; Success : out Status);
--
-- System wide setting. Maybe this should be controlled?
type Policy_Switches_Enum is (Require_Current_Work_Order,
Require_Comment_At_Check_In,
Require_Comment_Lines,
Journal_Comment_Lines,
Allow_Edit_Of_Work_Orders);
type Policy_Switches is array (Policy_Switches_Enum) of Boolean;
procedure Get_Policy_Switch (Value : out Policy_Switches;
For_Venture : Venture_Handle;
Success : out Status);
procedure Set_Policy_Switch (To_Value : Policy_Switches;
For_Venture : Venture_Handle;
Success : out Status);
--
-- For_Venture must be writable before its policy may be changed.
function Get_Notes (For_Venture : Venture_Handle) return String;
--
-- Constraint_Error will be raised if the handle is not open.
procedure Set_Notes (To_Value : String;
For_Venture : Venture_Handle;
Success : out Status);
--
-- For_Venture must be writable before its notes may be changed.
procedure Count_Orders (For_Venture : Venture_Handle;
Work_Orders : out Natural;
Success : out Status);
generic
with procedure Visit (Value : Work_Order_Id);
procedure Traverse_Orders
(The_Venture : Venture_Handle; Success : out Status);
--
-- Do not Create or Delete Work_Orders while traversing.
procedure Count_Lists (For_Venture : Venture_Handle;
Work_Order_Lists : out Natural;
Success : out Status);
generic
with procedure Visit (Value : Work_Order_List_Id);
procedure Traverse_Lists
(The_Venture : Venture_Handle; Success : out Status);
--
-- Do not Create or Delete Work_Order_Lists while traversing.
procedure Count_Default_Orders (For_Venture : Venture_Handle;
Users : out Natural;
Success : out Status);
--
-- Returns the number of users who have ever set a default
-- work_order for this venture.
generic
with procedure Visit (The_User : User_Id; Value : Work_Order_Id);
procedure Traverse_Default_Orders
(The_Venture : Venture_Handle; Success : out Status);
--
-- Do not Set_Default Work_Orders while traversing.
procedure Count_Default_Lists (For_Venture : Venture_Handle;
Users : out Natural;
Success : out Status);
--
-- Returns the number of users who have ever set a default
-- work_order_list for this venture.
generic
with procedure Visit (The_User : User_Id;
Value : Work_Order_List_Id);
procedure Traverse_Default_Lists
(The_Venture : Venture_Handle; Success : out Status);
--
-- Do not Set_Default Work_Order_Lists while traversing.
end Venture_Operations;
package Venture_Field_Operations is
subtype Field is Venture_Field;
function Null_Field return Field;
type Modifiable_Info_Record is
record
Is_Controlled : Boolean;
Display_Position : Natural;
end record;
procedure Create (Field_Name : String;
Descriptor_Info : Descriptor_Info_Record;
Modifiable_Info : Modifiable_Info_Record;
Default : String;
Result : out Field;
Success : out Status;
For_Venture : Venture_Handle;
Propagate : Boolean := True);
--
-- Creates a new user-defined field in a venture.
-- Field names may not contain Ascii.Lf, '"', or " => ".
-- All fields will have a default value. If the Default string
-- cannot be parsed, a value of False or 0 will be assumed.
-- Creating a new field will not affect any existing Work_Orders.
-- For_Venture must be writable.
-- If Propagate is true, all existing work_orders will be
-- updated to have this new field.
procedure Delete (Field_Name : String;
Success : out Status;
In_Venture : Venture_Handle;
Even_If_Data_Present : Boolean := False);
--
-- Deletes the field from the venture.
-- If work orders exist that have data in the field, the
-- operation fails unless Even_If_Data_Present is true.
-- This can be a very time consuming operation, as it must
-- cycle through all of the work orders and remove the field.
-- Each Work_Order will be opened with the Venture's action_id.
-- In_Venture must be writable.
procedure Find (Field_Name : String;
The_Field : out Field;
Success : out Status;
In_Venture : Venture_Handle);
--
-- Search for the named field.
-- Returns Null_Field (and a warning) if Field_Name cannot be found.
-- Letter case and leading and trailing spaces are ignored.
function Modifiable_Info (The_Field : Field)
return Modifiable_Info_Record;
procedure Set_Modifiable_Info (The_Field : Field;
Modifiable_Info : Modifiable_Info_Record;
Success : out Status);
function Name (The_Field : Field) return String;
function Descriptor_Info (The_Field : Field)
return Descriptor_Info_Record;
function Default (The_Field : Field) return String;
function Default (The_Field : Field) return Integer;
function Default (The_Field : Field) return Boolean;
--
-- May raise Constraint_Error or Work_Order_Errors.Type_Mismatch
procedure Set_Default (The_Field : in out Field;
In_Venture : Venture_Handle;
Value : String;
Success : out Status;
Propagate : Boolean := False);
procedure Set_Default (The_Field : in out Field;
In_Venture : Venture_Handle;
Value : Boolean;
Success : out Status;
Propagate : Boolean := False);
procedure Set_Default (The_Field : in out Field;
In_Venture : Venture_Handle;
Value : Integer;
Success : out Status;
Propagate : Boolean := False);
--
-- Changing the default value for a field will only affect existing
-- work_orders if Propagate is True. New work orders will have their
-- fields initialized to the current default values.
procedure Count (For_Venture : Venture_Handle;
Fields : out Natural;
Success : out Status);
generic
with procedure Visit (Value : Field);
procedure Traverse (The_Venture : Venture_Handle; Success : out Status);
--
-- Do not Create or Delete fields while traversing.
end Venture_Field_Operations;
package Venture_Display is
procedure Display (Which : Venture_Id;
Options : String := "";
To_File : Io.File_Type := Io.Current_Output);
--
-- Write out a venture to a text file.
procedure Edit (Which : Venture_Id);
--
-- Cause the Venture_Object_Editor to display a unit.
end Venture_Display;
package Work_Order_Control is
procedure Find (Name : String;
Result : out Work_Order_Id;
Success : out Status);
--
-- Invoke name resolution on a string.
-- Returns bad status if the work_order cannot be found.
procedure Find (Work_Order_Number : Long_Integer;
Result : out Work_Order_Id;
Success : out Status);
--
-- A Work_Order_Number can be obtained from the function of
-- that name below. Numbers are unique.
procedure Create (Work_Order_Name : String;
The_Handle : out Work_Order_Handle;
Success : out Status;
On_Venture : Venture_Handle;
On_List : Work_Order_List_Handle :=
Null_Work_Order_List_Handle;
Notes : String := "";
Storage : System.Segment := System.Null_Segment;
For_User : User_Id := Default.Session);
--
-- New work_order will be open for Update.
-- On_Venture (and On_List if supplied) must be writable.
-- The Venture's action will be used, so close The_Handle
-- (and On_List) before closing On_Venture.
procedure Open (The_Work_Order : Work_Order_Id;
The_Handle : out Work_Order_Handle;
Success : out Status;
Mode : Open_Mode := Read;
Storage : System.Segment := System.Null_Segment;
Action_Id : Action.Id := Action.Null_Id);
--
-- The_Work_Order may not be opened with mode None.
procedure Close (The_Handle : in out Work_Order_Handle;
Success : out Status);
--
-- The_Handle will be set to Null_Work_Order_Handle after closing.
function Id (The_Handle : Work_Order_Handle) return Work_Order_Id;
function Mode (The_Handle : Work_Order_Handle) return Open_Mode;
function Full_Name (The_Handle : Work_Order_Handle) return String;
-- These information functions may be used on any handle.
end Work_Order_Control;
package Work_Order_Operations is
procedure Set_Default (To_Order : Work_Order_Handle;
For_Venture : Venture_Handle;
Success : out Status;
For_User : User_Id := Default.Session);
--
-- To_Order may be the Null_Work_Order_Handle.
-- For_Venture must be writable.
procedure Get_Default (On_Venture : Venture_Handle;
Result : out Work_Order_Id;
Success : out Status;
For_User : User_Id := Default.Session;
Ignore_Garbage : Boolean := True);
--
-- If Ignore_Garbage is True and the default work_order no
-- longer exists, Nil will be returned instead.
-- These two operations are really Venture operations.
type Status_Enumeration is (Pending, In_Progress, Closed);
subtype Configuration_Object is Directory.Object;
subtype Element_Name is String;
subtype Generation is Natural;
procedure Close (The_Order : Work_Order_Handle; Success : out Status);
--
-- Sets the Status_Enumeration to Closed.
-- The_Order must be writable.
procedure Add_User (To_Order : Work_Order_Handle;
Success : out Status;
The_User : User_Id := Default.Session);
procedure Add_Version (To_Order : Work_Order_Handle;
The_Configuration : Configuration_Object;
The_Element : Element_Name;
The_Generation : Generation;
Success : out Status;
When_Added : Calendar.Time := Calendar.Clock);
procedure Add_Configuration
(To_Order : Work_Order_Handle;
The_Configuration : Configuration_Object;
Success : out Status;
When_Added : Calendar.Time := Calendar.Clock);
procedure Add_Comment_Line
(To_Order : Work_Order_Handle;
The_Comment_Line : String;
The_Element_Name : Element_Name;
Success : out Status;
The_User : User_Id := Default.Session;
When_Added : Calendar.Time := Calendar.Clock);
-- The procedures above add new elements to the pre-defined fields.
-- To_Order must be writable.
function Work_Order_Number
(The_Order : Work_Order_Id) return Long_Integer;
--
-- 0 is a nil Work_Order_Number.
procedure Get_Parent (The_Order : Work_Order_Handle;
Result : out Venture_Id;
Success : out Status);
procedure Get_Status (The_Order : Work_Order_Handle;
Result : out Status_Enumeration;
Success : out Status);
type User_Info is
record
The_User : User_Id;
The_Time : Calendar.Time;
end record;
procedure Create_Info (The_Order : Work_Order_Handle;
The_Info : out User_Info;
Success : out Status);
procedure Close_Info (The_Order : Work_Order_Handle;
The_Info : out User_Info;
Success : out Status);
--
function Create_User_Name (The_Order : Work_Order_Handle) return String;
function Close_User_Name (The_Order : Work_Order_Handle) return String;
--------------------------------------------------------------
function Get_Notes (For_Order : Work_Order_Handle) return String;
--
-- Constraint_Error will be raised if the handle is not open.
procedure Set_Notes (To_Value : String;
For_Order : Work_Order_Handle;
Success : out Status);
--
-- For_Order must be writable before its notes may be changed.
-- Changing the notes will not mark an order as being In_Progress.
procedure Count_Versions (For_Work_Order : Work_Order_Handle;
Versions : out Natural;
Success : out Status);
generic
with procedure Visit (The_Configuration : Configuration_Object;
The_Element : Element_Name;
The_Generation : Generation;
The_Time : Calendar.Time);
procedure Traverse_Versions
(For_Work_Order : Work_Order_Handle; Success : out Status);
--
-- Do not Add_Versions while traversing.
-- Versions are time-ordered.
procedure Count_Configurations (For_Work_Order : Work_Order_Handle;
Configurations : out Natural;
Success : out Status);
generic
with procedure Visit (The_Configuration : Configuration_Object;
The_Time : Calendar.Time);
procedure Traverse_Configurations
(For_Work_Order : Work_Order_Handle; Success : out Status);
--
-- Do not Add_Configurations while traversing.
-- Configurations are time-ordered.
procedure Count_Users (For_Work_Order : Work_Order_Handle;
Users : out Natural;
Success : out Status);
generic
with procedure Visit (The_User : User_Id);
procedure Traverse_Users
(For_Work_Order : Work_Order_Handle; Success : out Status);
--
-- Do not Add_Users while traversing.
procedure Count_Comments (For_Work_Order : Work_Order_Handle;
Comments : out Natural;
Success : out Status);
generic
with procedure Visit (The_User : User_Id;
User_Name : String;
The_Comment : String;
The_Element : Element_Name;
The_Time : Calendar.Time);
procedure Traverse_Comments
(For_Work_Order : Work_Order_Handle; Success : out Status);
--
-- Do not Add_Comments while traversing.
-- Comments are time-ordered
-- The User_Name may be good even if the The_User no longer
-- exists. If the comment was generated in a Delta 2 system
-- then the user name is stored separately.
end Work_Order_Operations;
package Work_Order_Field_Operations is
subtype Field is Work_Order_Field;
function Null_Field return Work_Order_Field;
procedure Find (Field_Name : String;
The_Field : out Field;
Success : out Status;
In_Work_Order : Work_Order_Handle);
--
-- Search for the named field.
-- Returns Null_Field (and a warning) if Field_Name cannot be found.
-- Letter case and leading and trailing spaces are ignored.
function Name (The_Field : Field) return String;
function Descriptor_Info (The_Field : Field)
return Descriptor_Info_Record;
procedure High_Index (The_Field : Field;
Result : out Natural;
Success : out Status);
--
-- Return the highest index which has been used.
function Value (The_Field : Field) return String;
function Value (The_Field : Field) return Integer;
function Value (The_Field : Field) return Boolean;
function Value (The_Field : Field; Index : Natural) return String;
function Value (The_Field : Field; Index : Natural) return Integer;
function Value (The_Field : Field; Index : Natural) return Boolean;
-- Returns the current value.
-- If there is no current value, returns the default value.
-- Raises Type_Mismatch if the selector doesn't conform to the
-- type of the field.
-- Raises Mismatched_Vector_Operation if the selector doesn't
-- conform to the vector type.
-- Raises Constraint_Error on the Null_Field.
-- All uninitialized fields in a vector return the default.
-- An Index of 0 is interpreted as High_Index (1 if High_Index = 0).
function Is_Default (The_Field : Field) return Boolean;
function Is_Default
(The_Field : Field; Index : Positive) return Boolean;
--
-- Returns True if the field in question has never been
-- assigned a value using one of the procedures below.
procedure Set_Value (The_Field : in out Field;
The_Handle : Work_Order_Handle;
Value : String;
Success : out Status);
procedure Set_Value (The_Field : in out Field;
The_Handle : Work_Order_Handle;
Value : Boolean;
Success : out Status);
procedure Set_Value (The_Field : in out Field;
The_Handle : Work_Order_Handle;
Value : Integer;
Success : out Status);
procedure Set_Value (The_Field : in out Field;
The_Handle : Work_Order_Handle;
Index : Natural;
Value : String;
Success : out Status);
procedure Set_Value (The_Field : in out Field;
The_Handle : Work_Order_Handle;
Index : Natural;
Value : Boolean;
Success : out Status);
procedure Set_Value (The_Field : in out Field;
The_Handle : Work_Order_Handle;
Index : Natural;
Value : Integer;
Success : out Status);
--
-- Sets the value of the field.
-- The field must not already have a (non-default) value.
-- An index of 0 is interpreted as High_Index + 1.
-- The_Handle must be writable.
procedure Count (For_Work_Order : Work_Order_Handle;
Fields : out Natural;
Success : out Status);
generic
with procedure Visit (Value : Field);
procedure Traverse (The_Work_Order : Work_Order_Handle;
Success : out Status);
--
-- Do not Create or Delete fields while traversing.
end Work_Order_Field_Operations;
package Work_Order_Display is
procedure Display (Which : Work_Order_Id;
Options : String := "";
To_File : Io.File_Type := Io.Current_Output);
--
-- Write out a work_order to a text file.
procedure Edit (Which : Work_Order_Id);
--
-- Cause the Work_Order_Object_Editor to display an object.
end Work_Order_Display;
package Work_Order_List_Control is
procedure Find (List_Name : String;
Result : out Work_Order_List_Id;
Success : out Status);
--
-- Invoke name resolution on a string.
-- Returns bad status if the list cannot be found.
procedure Create (List_Name : String := ">>OBJECT NAME<<";
The_Handle : out Work_Order_List_Handle;
Success : out Status;
On_Venture : Venture_Handle;
Notes : String := "";
Storage : System.Segment := System.Null_Segment);
--
-- New work_order_list will be open for Update.
-- On_Venture must be writable.
-- The Venture's action will be used, so close The_Handle
-- before closing On_Venture.
procedure Open (The_List : Work_Order_List_Id;
The_Handle : out Work_Order_List_Handle;
Success : out Status;
Mode : Open_Mode := Read;
Storage : System.Segment := System.Null_Segment;
Action_Id : Action.Id := Action.Null_Id);
--
-- The_List may not be opened with mode None.
procedure Close (The_Handle : in out Work_Order_List_Handle;
Success : out Status);
--
-- The_Handle is set to Null_Work_Order_List_Handle after closing.
function Id (The_Handle : Work_Order_List_Handle)
return Work_Order_List_Id;
function Mode (The_Handle : Work_Order_List_Handle) return Open_Mode;
function Full_Name (The_Handle : Work_Order_List_Handle) return String;
-- These information functions may be used on any handle.
end Work_Order_List_Control;
package Work_Order_List_Operations is
procedure Set_Default (To_List : Work_Order_List_Handle;
For_Venture : Venture_Handle;
Success : out Status;
For_User : User_Id := Default.Session);
--
-- To_List may be the Null_Work_Order_List_Handle.
-- For_Venture must be writable.
procedure Get_Default (On_Venture : Venture_Handle;
Result : out Work_Order_List_Id;
Success : out Status;
For_User : User_Id := Default.Session;
Ignore_Garbage : Boolean := True);
--
-- If Ignore_Garbage is True and the default list no longer
-- exists, Nil will be returned instead.
-- These two operations are really Venture operations.
procedure Add (The_Work_Order : Work_Order_Handle;
To_List : Work_Order_List_Handle;
Success : out Status);
--
-- Adds a work order to a list.
-- The_Work_Order must have the same parent venture as To_List.
-- To_List must be writable.
procedure Remove (The_Work_Order : Work_Order_Id;
From_List : Work_Order_List_Handle;
Success : out Status);
--
-- Remove a work_order from a list.
-- The work order itself is unaffected.
-- From_List must be writable.
procedure Get_Parent (The_List : Work_Order_List_Handle;
Result : out Venture_Id;
Success : out Status);
function Get_Notes (For_List : Work_Order_List_Handle) return String;
--
-- Constraint_Error will be raised if the handle is not open.
procedure Set_Notes (To_Value : String;
For_List : Work_Order_List_Handle;
Success : out Status);
--
-- For_List must be writable before its notes may be changed.
procedure Count (For_List : Work_Order_List_Handle;
Work_Orders : out Natural;
Success : out Status);
generic
with procedure Visit (The_Work_Order : Work_Order_Id);
procedure Traverse (For_List : Work_Order_List_Handle;
Success : out Status);
--
-- Do not Add or Remove work orders while traversing.
end Work_Order_List_Operations;
package Work_Order_List_Display is
procedure Display (Which : Work_Order_List_Id;
Options : String := "";
To_File : Io.File_Type := Io.Current_Output);
--
-- Write out a Work_Order_List to a text file.
procedure Edit (Which : Work_Order_List_Id);
--
-- Cause the Work_Order_List_Object_Editor to display an object.
end Work_Order_List_Display;
end Work_Order_Implementation;with System;
with Action;
with Directory;
with Io_Exceptions;
package Device_Independent_Io is
-- Device_Independent_IO is designed to provide a uniform method of
-- accessing sequential devices, including files, terminals, windows,
-- printers, and tape drives. Its clients are expected to be Text_IO and
-- Sequential_IO, though there may be others.
-- The assumption is made that devices deal in bytes or characters rather
-- than elemental types.
pragma Subsystem (Input_Output);
pragma Module_Name (4, 3208);
type File_Type is private;
type File_Mode is (In_File, Out_File);
subtype Class is Directory.Class;
subtype Subclass is Directory.Subclass;
subtype Version is Directory.Version;
subtype Byte is System.Byte;
subtype Byte_String is System.Byte_String;
procedure Open (File : in out File_Type;
Mode : File_Mode;
Name : String;
Form : String := "";
With_Class : Directory.Class := Directory.Nil;
Action_Id : Action.Id := Action.Null_Id);
procedure Open (File : in out File_Type;
Mode : File_Mode;
Object : Version;
Form : String := "";
With_Class : Directory.Class := Directory.Nil;
Action_Id : Action.Id := Action.Null_Id);
procedure Append (File : in out File_Type;
Name : String;
Form : String := "";
With_Class : Directory.Class := Directory.Nil;
Action_Id : Action.Id := Action.Null_Id);
procedure Append (File : in out File_Type;
Object : Version;
Form : String := "";
With_Class : Directory.Class := Directory.Nil;
Action_Id : Action.Id := Action.Null_Id);
-- open the object for output and position at end of file
procedure Create (File : in out File_Type;
Mode : File_Mode := Out_File;
Name : String := "";
Form : String := "";
With_Class : Class := Directory.Nil;
With_Subclass : Subclass := Directory.Nil;
Action_Id : Action.Id := Action.Null_Id);
-- creates the named object, if it currently does not exist
-- declaration of a new version is dependent on the class of the object
-- if object does not exists, and class is nil, file is assumed.
procedure Close (File : in out File_Type);
procedure Delete (File : in out File_Type);
procedure Reset (File : in out File_Type; Mode : File_Mode);
procedure Reset (File : in out File_Type);
procedure Save (File : File_Type; Immediate_Effect : Boolean := True);
-- Save the current contents of the file, but leave it open
-- Immediate_Effect => don't wait until the action is committed
function Mode (File : File_Type) return File_Mode;
function Name (File : File_Type) return String;
function Form (File : File_Type) return String;
function Get_Class (File : File_Type) return Class;
function Get_Subclass (File : File_Type) return Subclass;
function Get_Version (File : File_Type) return Version;
function Get_Action (File : File_Type) return Action.Id;
function Is_Open (File : File_Type) return Boolean;
function End_Of_File (File : File_Type) return Boolean;
procedure Read (File : File_Type;
Item : out Byte_String;
Count : out Natural);
procedure Read (File : File_Type; Item : out Byte);
procedure Read (File : File_Type; Item : out String; Count : out Natural);
procedure Read (File : File_Type; Item : out Character);
procedure Write (File : File_Type; Item : Byte_String);
procedure Write (File : File_Type; Item : Byte);
procedure Write (File : File_Type; Item : String);
procedure Write (File : File_Type; Item : Character);
function Is_Interactive (File : File_Type) return Boolean;
-- The user-visible function that determines whether or not a file
-- is interactive.
function Is_Empty (File : File_Type) return Boolean;
-- Determine if the file has any contents
generic
type Derived_File_Type is limited private;
-- Only works for types derived from Device_Independent_IO.File_Type
pragma Must_Be_Constrained (Derived_File_Type);
package File_Type_Conversions is
function From_Standard (File : File_Type) return Derived_File_Type;
function To_Standard (File : Derived_File_Type) return File_Type;
end File_Type_Conversions;
-- Ability to convert between Device_Independent_IO File_Type and those
-- used by its clients.
-- Provided principally to allow setting of options for device_specific
-- packages that may be used in conjunction with Text_IO, etc.
-- Specific clients may buffer data in ways not visible to
-- Device_Independent_IO, so this is a generally dangerous operation for
-- Input/Output operations.
generic
type Element_Type is private;
package Type_Specific_Operations is
function Read (File : File_Type) return Element_Type;
procedure Read (File : File_Type; Item : out Element_Type);
procedure Write (File : File_Type; Item : Element_Type);
end Type_Specific_Operations;
-- Type_Specific_Operations make it possible to implement the equivalent
-- of Sequential_IO or Polymorphic_Sequential_IO.
-- Exceptions
Status_Error : exception renames Io_Exceptions.Status_Error;
Mode_Error : exception renames Io_Exceptions.Mode_Error;
Name_Error : exception renames Io_Exceptions.Name_Error;
Use_Error : exception renames Io_Exceptions.Use_Error;
Device_Error : exception renames Io_Exceptions.Device_Error;
End_Error : exception renames Io_Exceptions.End_Error;
Data_Error : exception renames Io_Exceptions.Data_Error;
end Device_Independent_Io;with Io_Exceptions;
with Device_Independent_Io;
generic
type Element_Type is private;
pragma Must_Be_Constrained (Element_Type);
package Direct_Io is
pragma Subsystem (Input_Output);
pragma Module_Name (4, 3203);
type File_Type is limited private;
type File_Mode is (In_File, Inout_File, Out_File);
type Count is new Integer range 0 .. Integer'Last / Element_Type'Size;
subtype Positive_Count is Count range 1 .. Count'Last;
-- File management
procedure Create (File : in out File_Type;
Mode : File_Mode := Inout_File;
Name : String := "";
Form : String := "");
procedure Open (File : in out File_Type;
Mode : File_Mode;
Name : String;
Form : String := "");
procedure Close (File : in out File_Type);
procedure Delete (File : in out File_Type);
procedure Reset (File : in out File_Type; Mode : File_Mode);
procedure Reset (File : in out File_Type);
function Mode (File : File_Type) return File_Mode;
function Name (File : File_Type) return String;
function Form (File : File_Type) return String;
function Is_Open (File : File_Type) return Boolean;
-- Input and output operations
procedure Read (File : File_Type;
Item : out Element_Type;
From : Positive_Count);
procedure Read (File : File_Type; Item : out Element_Type);
procedure Write (File : File_Type;
Item : Element_Type;
To : Positive_Count);
procedure Write (File : File_Type; Item : Element_Type);
procedure Set_Index (File : File_Type; To : Positive_Count);
function Index (File : File_Type) return Positive_Count;
function Size (File : File_Type) return Count;
function End_Of_File (File : File_Type) return Boolean;
-- Exceptions
Status_Error : exception renames Io_Exceptions.Status_Error;
Mode_Error : exception renames Io_Exceptions.Mode_Error;
Name_Error : exception renames Io_Exceptions.Name_Error;
Use_Error : exception renames Io_Exceptions.Use_Error;
Device_Error : exception renames Io_Exceptions.Device_Error;
End_Error : exception renames Io_Exceptions.End_Error;
Data_Error : exception renames Io_Exceptions.Data_Error;
private
-- implementation dependent
type File_Descriptor;
type File_Type is access File_Descriptor;
pragma Segmented_Heap (File_Type);
end Direct_Io;with Action;
with Device_Independent_Io;
with Directory;
with Io_Exceptions;
with Text_Io;
package Io is
pragma Subsystem (Input_Output, Private_Part => Closed);
pragma Module_Name (4, 3506);
type File_Type is private;
subtype File_Mode is Text_Io.File_Mode;
In_File : constant File_Mode := Text_Io.In_File;
Out_File : constant File_Mode := Text_Io.Out_File;
subtype Count is Text_Io.Count;
subtype Positive_Count is Count range 1 .. Count'Last;
Unbounded : constant Count := Text_Io.Unbounded;
subtype Field is Integer range 0 .. Integer'Last;
subtype Number_Base is Integer range 2 .. 16;
subtype Type_Set is Text_Io.Type_Set;
Upper_Case : constant Type_Set := Text_Io.Upper_Case;
Lower_Case : constant Type_Set := Text_Io.Lower_Case;
-- File Management
procedure Create (File : in out File_Type;
Mode : File_Mode := Out_File;
Name : String := "";
Form : String := "");
procedure Open (File : in out File_Type;
Mode : File_Mode := Out_File;
Name : String;
Form : String := "");
procedure Open (File : in out File_Type;
Mode : File_Mode;
Object : Directory.Version;
Form : String := "");
-- Open a particular directory version; not Text_IO
procedure Append
(File : in out File_Type; Name : String; Form : String := "");
procedure Append (File : in out File_Type;
Object : Directory.Version;
Form : String := "");
-- Open existing file for output, positioned at end of file; not Text_IO
-- Output starting after an Append is on a new line, but on the same page
-- as the previous end of the file
procedure Flush (File : File_Type);
-- Force any buffer characters out to file
procedure Save (File : File_Type);
-- Save the current contents of the file, but leave it open; calls Flush
procedure Close (File : in out File_Type);
procedure Delete (File : in out File_Type);
procedure Reset (File : in out File_Type; Mode : File_Mode);
procedure Reset (File : in out File_Type);
function Mode (File : File_Type) return File_Mode;
function Name (File : File_Type) return String;
function Form (File : File_Type) return String;
function Is_Open (File : File_Type) return Boolean;
-- Control of default input, output and error files; error not Text_IO
procedure Set_Input (File : File_Type);
procedure Set_Output (File : File_Type);
procedure Set_Error (File : File_Type);
-- Equivalent of an Open/Create followed by above; not in Text_IO
procedure Set_Input (Name : String := "<SELECTION>");
procedure Set_Output (Name : String := ">>FILE NAME<<");
procedure Set_Error (Name : String := ">>FILE NAME<<");
function Standard_Input return File_Type;
function Standard_Output return File_Type;
function Standard_Error return File_Type;
function Standard_Error return Text_Io.File_Type;
function Current_Input return File_Type;
function Current_Output return File_Type;
function Current_Error return File_Type;
function Current_Error return Text_Io.File_Type;
-- For each default files, f, Set_f pushes that File_Type entry on a stack
-- for the job. Pop_f removes the top of the stack. Reset is equivalent
-- to a Close and a Pop.
--
-- All open files in the default file stack at job termination are closed.
procedure Reset_Error;
procedure Reset_Input;
procedure Reset_Output;
procedure Pop_Error;
procedure Pop_Input;
procedure Pop_Output;
-- Specification of line and page lengths
procedure Set_Line_Length (File : File_Type; To : Count);
procedure Set_Line_Length (To : Count);
procedure Set_Page_Length (File : File_Type; To : Count);
procedure Set_Page_Length (To : Count);
function Line_Length (File : File_Type) return Count;
function Line_Length return Count;
function Page_Length (File : File_Type) return Count;
function Page_Length return Count;
-- Column, Line and Page Control
procedure New_Line (File : File_Type; Spacing : Positive_Count := 1);
procedure New_Line (Spacing : Positive_Count := 1);
procedure Skip_Line (File : File_Type; Spacing : Positive_Count := 1);
procedure Skip_Line (Spacing : Positive_Count := 1);
function End_Of_Line (File : File_Type) return Boolean;
function End_Of_Line return Boolean;
procedure New_Page (File : File_Type);
procedure New_Page;
procedure Skip_Page (File : File_Type);
procedure Skip_Page;
function End_Of_Page (File : File_Type) return Boolean;
function End_Of_Page return Boolean;
function End_Of_File (File : File_Type) return Boolean;
function End_Of_File return Boolean;
procedure Set_Col (File : File_Type; To : Positive_Count);
procedure Set_Col (To : Positive_Count);
procedure Set_Line (File : File_Type; To : Positive_Count);
procedure Set_Line (To : Positive_Count);
function Col (File : File_Type) return Positive_Count;
function Col return Positive_Count;
function Line (File : File_Type) return Positive_Count;
function Line return Positive_Count;
function Page (File : File_Type) return Positive_Count;
function Page return Positive_Count;
-- Character Input-Output
procedure Get (File : File_Type; Item : out Character);
procedure Get (Item : out Character);
procedure Put (File : File_Type; Item : Character);
procedure Put (Item : Character);
procedure Echo (Item : Character);
-- String Input-Output
procedure Get (File : File_Type; Item : out String);
procedure Get (Item : out String);
procedure Put (File : File_Type; Item : String);
procedure Put (Item : String);
procedure Echo (Item : String := "");
procedure Get_Line
(File : File_Type; Item : out String; Last : out Natural);
procedure Get_Line (Item : out String; Last : out Natural);
procedure Put_Line (File : File_Type; Item : String);
procedure Put_Line (Item : String);
procedure Echo_Line (Item : String := "");
-- String Input-Output not in Text_IO
function Get_Line (File : File_Type) return String;
function Get_Line return String;
procedure Get (File : File_Type;
Item : out String;
Last : out Natural;
End_Of_Line : out Boolean;
End_Of_Page : out Boolean;
End_Of_File : out Boolean);
-- Get all or part of a line.
-- End_Of_Line iff Item contains the end of line (possibly null)
-- End_Of_Page iff End_Of_Line and this is the last line of the page
-- End_Of_File iff End_Of_Page and this is the last page of the file
--
-- The intent if for each call to return as many characters from the
-- line as fit, but Last /= Item'Last doesn't implies End_Of_Line.
-- equivalents for instantiations of the type-specific generics
-- Integer Input-Output; equivalent to an instantiation of Integer_IO
procedure Get (File : File_Type; Item : out Integer; Width : Field := 0);
procedure Get (Item : out Integer; Width : Field := 0);
procedure Put (File : File_Type;
Item : Integer;
Width : Field := 0;
Base : Number_Base := 10);
procedure Put (Item : Integer;
Width : Field := 0;
Base : Number_Base := 10);
procedure Echo (Item : Integer;
Width : Field := 0;
Base : Number_Base := 10);
-- Float Input-Output; equivalent to an instantiation of Float_IO
procedure Get (File : File_Type; Item : out Float; Width : Field := 0);
procedure Get (Item : out Float; Width : Field := 0);
procedure Put (File : File_Type;
Item : Float;
Fore : Field := 2;
Aft : Field := 14;
Exp : Field := 3);
procedure Put (Item : Float;
Fore : Field := 2;
Aft : Field := 14;
Exp : Field := 3);
procedure Echo (Item : Float;
Fore : Field := 2;
Aft : Field := 14;
Exp : Field := 3);
-- Boolean Input-Output; equivalent to an instantiation of Enumeration_IO
procedure Get (File : File_Type; Item : out Boolean);
procedure Get (Item : out Boolean);
procedure Put (File : File_Type; Item : Boolean; Width : Field := 0);
procedure Put (Item : Boolean; Width : Field := 0);
procedure Echo (Item : Boolean; Width : Field := 0);
-- Generic package for Input-Output of Integer Types
generic
type Num is range <>;
package Integer_Io is
Default_Width : Field := Num'Width;
Default_Base : Number_Base := 10;
procedure Get (File : File_Type; Item : out Num; Width : Field := 0);
procedure Get (Item : out Num; Width : Field := 0);
procedure Put (File : File_Type;
Item : Num;
Width : Field := Default_Width;
Base : Number_Base := Default_Base);
procedure Put (Item : Num;
Width : Field := Default_Width;
Base : Number_Base := Default_Base);
procedure Get (From : String; Item : out Num; Last : out Positive);
procedure Put (To : out String;
Item : Num;
Base : Number_Base := Default_Base);
end Integer_Io;
-- Generic package for Input-Output of Floating Point Types
generic
type Num is digits <>;
package Float_Io is
Default_Fore : Field := 2;
Default_Aft : Field := Num'Digits - 1;
Default_Exp : Field := 3;
procedure Get (File : File_Type; Item : out Num; Width : Field := 0);
procedure Get (Item : out Num; Width : Field := 0);
procedure Put (File : File_Type;
Item : Num;
Fore : Field := Default_Fore;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
procedure Put (Item : Num;
Fore : Field := Default_Fore;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
procedure Get (From : String; Item : out Num; Last : out Positive);
procedure Put (To : out String;
Item : Num;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
end Float_Io;
-- Generic package for Input-Output of Fixed Point Types
generic
type Num is delta <>;
package Fixed_Io is
Default_Fore : Field := Num'Fore;
Default_Aft : Field := Num'Aft;
Default_Exp : Field := 0;
procedure Get (File : File_Type; Item : out Num; Width : Field := 0);
procedure Get (Item : out Num; Width : Field := 0);
procedure Put (File : File_Type;
Item : Num;
Fore : Field := Default_Fore;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
procedure Put (Item : Num;
Fore : Field := Default_Fore;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
procedure Get (From : String; Item : out Num; Last : out Positive);
procedure Put (To : out String;
Item : Num;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
end Fixed_Io;
-- Generic package for Input-Output of Enumeration Types
generic
type Enum is (<>);
package Enumeration_Io is
Default_Width : Field := 0;
Default_Setting : Type_Set := Upper_Case;
procedure Get (File : File_Type; Item : out Enum);
procedure Get (Item : out Enum);
procedure Put (File : File_Type;
Item : Enum;
Width : Field := Default_Width;
Set : Type_Set := Default_Setting);
procedure Put (Item : Enum;
Width : Field := Default_Width;
Set : Type_Set := Default_Setting);
procedure Get (From : String; Item : out Enum; Last : out Positive);
procedure Put (To : out String;
Item : Enum;
Set : Type_Set := Default_Setting);
end Enumeration_Io;
-- Interchange with other system file_types
--
-- Compatibility with Device_Independendent_IO is solely for the purpose
-- of allowing access to device-specific options at open.
--
-- Interchange of Get/Put and Read/Write operations between IO and
-- Device_Independent_IO is undefined due to internal buffering in IO,
-- though Flush can be used on output to clear the buffer.
--
-- Free interchange of operations with Text_IO is supported.
function Convert (File : File_Type) return Text_Io.File_Type;
function Convert (File : Text_Io.File_Type) return File_Type;
function Convert (File : File_Type) return Device_Independent_Io.File_Type;
function Convert (File : Device_Independent_Io.File_Type) return File_Type;
function "=" (L, R : File_Mode) return Boolean renames Text_Io."=";
function "=" (L, R : Type_Set) return Boolean renames Text_Io."=";
function "<" (L, R : Count) return Boolean renames Text_Io."<";
function "=" (L, R : Count) return Boolean renames Text_Io."=";
function ">" (L, R : Count) return Boolean renames Text_Io.">";
-- Operate on multiple input files matching a wildcard
generic
with procedure Process (File : in out File_Type) is <>;
with procedure Note_Error (Message : String) is Io.Put_Line;
procedure Wildcard_Iterator (Names : String);
-- Calls Process once with an open File corresponding to each of Names
-- Name errors and unhandled expections are reported through Note_Error.
-- Closes File after each call to Process, if not already closed.
procedure Convert (From : Device_Independent_Io.File_Type;
To : in out Text_Io.File_Type);
-- Conversion form that allows changing limited private file_type
-- File management logical overloads. Each procedure duplicates one
-- above, but with direct control over the Action.ID used.
procedure Create (File : in out File_Type;
Mode : File_Mode := Out_File;
Name : String := "";
Form : String := "";
Action_Id : Action.Id);
procedure Open (File : in out File_Type;
Mode : File_Mode := Out_File;
Name : String;
Form : String := "";
Action_Id : Action.Id);
procedure Open (File : in out File_Type;
Mode : File_Mode;
Object : Directory.Version;
Form : String := "";
Action_Id : Action.Id);
procedure Append (File : in out File_Type;
Name : String;
Form : String := "";
Action_Id : Action.Id);
procedure Append (File : in out File_Type;
Object : Directory.Version;
Form : String := "";
Action_Id : Action.Id);
function Get_Action (File : File_Type) return Action.Id;
-- Exceptions
Status_Error : exception renames Io_Exceptions.Status_Error;
Mode_Error : exception renames Io_Exceptions.Mode_Error;
Name_Error : exception renames Io_Exceptions.Name_Error;
Use_Error : exception renames Io_Exceptions.Use_Error;
Device_Error : exception renames Io_Exceptions.Device_Error;
End_Error : exception renames Io_Exceptions.End_Error;
Data_Error : exception renames Io_Exceptions.Data_Error;
Layout_Error : exception renames Io_Exceptions.Layout_Error;
end Io;package Io_Exceptions is
Status_Error : exception;
Mode_Error : exception;
Name_Error : exception;
Use_Error : exception;
Device_Error : exception;
End_Error : exception;
Data_Error : exception;
Layout_Error : exception;
pragma Exception_Name (Status_Error, 271);
pragma Exception_Name (Status_Error, 256); -- 256..271
pragma Exception_Name (Mode_Error, 287);
pragma Exception_Name (Mode_Error, 272); -- 272..287
pragma Exception_Name (Name_Error, 303);
pragma Exception_Name (Name_Error, 288); -- 288..303
pragma Exception_Name (Use_Error, 319);
pragma Exception_Name (Use_Error, 304); -- 304..319
pragma Exception_Name (Device_Error, 335);
pragma Exception_Name (Device_Error, 320); -- 320..335
pragma Exception_Name (End_Error, 351);
pragma Exception_Name (End_Error, 336); -- 336..351
pragma Exception_Name (Data_Error, 367);
pragma Exception_Name (Data_Error, 352); -- 352..367
pragma Exception_Name (Layout_Error, 383);
pragma Exception_Name (Layout_Error, 368); -- 368..383
pragma Subsystem (Miscellaneous);
pragma Module_Name (4, 804);
end Io_Exceptions;with Action;
with Directory;
with Polymorphic_Io;
package Object_Set is
pragma Subsystem (Directory, Closed);
pragma Module_Name (4, 1721);
function Is_Set (Object : Directory.Object) return Boolean;
type Set is private;
procedure Create (Set_Name : String;
Set_Id : out Directory.Object;
Status : out Directory.Error_Status;
Action_Id : Action.Id := Action.Null_Id);
procedure Open (Set_Id : Directory.Object;
The_Set : out Set;
Status : out Directory.Error_Status;
Action_Id : Action.Id := Action.Null_Id;
For_Update : Boolean := False;
Prevent_Create : Boolean := False);
procedure Close (The_Set : Set; Status : out Directory.Error_Status);
function Is_Empty (The_Set : Set) return Boolean;
procedure Make_Empty (The_Set : in out Set);
-- The Set must be open for update. (all sets are initially empty).
function Is_Member (The_Set : Set; Id : Directory.Object) return Boolean;
procedure Add (The_Set : in out Set; Id : Directory.Object);
procedure Remove (The_Set : in out Set; Id : Directory.Object);
type Iterator is limited private;
procedure Init (Iter : out Iterator; The_Set : Set);
procedure Next (Iter : in out Iterator);
function Value (Iter : Iterator) return Directory.Object;
function Done (Iter : Iterator) return Boolean;
function Handle_Of (H : Set) return Polymorphic_Io.Handle;
-- returns the Polymorphic Io handle on the open set.
end Object_Set;with Action;
with Directory;
with Io_Exceptions;
with System;
package Pipe is
subtype Action_Id is Action.Id;
Null_Action_Id : constant Action_Id := Action.Null_Id;
subtype Byte is System.Byte;
subtype Byte_String is System.Byte_String;
subtype Object_Id is Directory.Version;
subtype Operate_Status is Integer;
Status_Error : exception renames Io_Exceptions.Status_Error;
Mode_Error : exception renames Io_Exceptions.Mode_Error;
Name_Error : exception renames Io_Exceptions.Name_Error;
Use_Error : exception renames Io_Exceptions.Use_Error;
Device_Error : exception renames Io_Exceptions.Device_Error;
End_Error : exception renames Io_Exceptions.End_Error;
Data_Error : exception renames Io_Exceptions.Data_Error;
Layout_Error : exception renames Io_Exceptions.Layout_Error;
-- Exceptions are raised iff the the comments following the operation
-- indicate that the exception is possible. All other exception
-- propagation is considered a bug in the underlying implementation.
-- A pipe is an object which contains a queue of messages, possibly empty.
-- By opening the object for write, one can do "Write" operations which
-- append messages to the end of the queue. By opening the object for
-- read, one can do "Read" operations which consume messages from the
-- beginning of the queue. Each message is read by exactly one Read
-- operation; thus, in the face of concurrent Reads, each client may see
-- just a subset of the messages that were written to the pipe.
-- It is ok to make concurrent calls to this package. BUT, this does NOT
-- include calls which supply the same Handle; this is considered
-- erroneous. The implementation does not prevent such erroneous behavior;
-- this behavior might cause your Handle to be left inconsistent, but the
-- internal representation of the pipe itself is protected and will remain
-- consistent; thus, other Handle's (including those in other jobs) should
-- still work properly.
function Pipe_Class return Directory.Class;
type Handle is private;
Null_Handle : constant Handle;
-- Contains control information which is pertinent to a particular "open"
-- of a particular pipe. Other control information (about pipes) is kept
-- internally. Logically, a Handle is limited private. Use of multiple
-- copies is considered erroneous. The implementation does not prevent
-- such erroneous behavior. At worst, an erroneous program will be able
-- to Read/Write a pipe which is still open elsewhere, even though other
-- copies of the Handle have been closed; the internal representation of
-- the pipe itself is protected from such erroneous behavior and will
-- remain consistent.
function Max_Buffer_Size return Positive;
-- Measured in bytes. Currently about half the maximum size of a heap.
function Default_Buffer_Size return Positive;
-- Measured in bytes. Currently about 20K bytes.
function Message_Overhead return Natural;
-- Measured in bytes. Currently about 8 bytes. Clients can compute the
-- value of B = n * (c + M), where "c" is the result of this function, "M"
-- is the fixed size of messages supplied to the Write operation, "n" is
-- the desired capacity of the buffer (in messages), and "B" is the
-- resulting requirement for buffer size, in bytes. This function may
-- change between releases of the system.
type Pipe_Open_Mode is (Exclusive_Read, Shared_Read,
Exclusive_Write, Shared_Write, Exclusive);
-- The read modes allow one to use Read operations to consume messages from
-- the beginning of the queue. The write modes allow one to use Write
-- operations to append messages to the end of the queue. The same client
-- can use both Read and Write by opening the pipe multiple times. The
-- compatibility matrix is as follows:
-- Other action compatibility matrix:
-- Current Mode
-- (other actions)
-- ER SR EW SW E
-- ---------------------
-- ER | X X
-- |
-- SR | X X X
-- |
-- Desired EW | X X
-- Mode |
-- SW | X X X
-- |
-- E |
-- ---------------------
-- Absence of an "X" indicates that the desired access will not be granted
-- if any OTHER action (not including requesting action) has the indicated
-- current access. Via Max_Wait, queueing is available when access is
-- denied for this reason.
-- Assuming access is not denied by the above rules, the following matrix
-- indicates the upgrade compatibility rules:
-- Upgrade matrix:
-- Current Access
-- (by same action)
-- ER SR EW SW E
-- ---------------------
-- ER | ER ER E
-- |
-- SR | ER SR E
-- Desired |
-- Access EW | EW EW E
-- |
-- SW | EW SW E
-- |
-- E | E E E E E
-- ---------------------
-- Absence of a mode indicates that the desired access will not be granted
-- if the requesting action already has the indicated current access.
-- Queueing is not available in this case. Presence of a mode indicates
-- that the access will be granted, and indicates the new lock mode in
-- which the action holds object.
-- Note that the upgrade rules imply that a single action cannot be used to
-- both read and write the same pipe. Of course, a single task can read
-- and write the same pipe by using 2 actions.
-- RESTRICTION: In Delta, the Create operation only supports Exclusive,
-- and the Open operation only supports Shared_Read, Shared_Write, and
-- Exclusive.
procedure Create (Pipe : in out Handle;
Mode : Pipe_Open_Mode;
Name : String;
Action : Action_Id := Null_Action_Id;
Max_Wait : Duration := Directory.Default_Wait;
Permanent_Contents : Boolean := False;
Buffer_Size : Positive := Default_Buffer_Size;
Reader_Buffer_Size : Natural := 0);
-- Since it's an object, a pipe lives in the directory system, as specified
-- by the Name parameter. Naming of pipes is the same as for vanilla
-- files. Multiple versions of a pipe are allowed.
-- With respect to disk space, the system reserves the right to allocate
-- disk space for the entire buffer, at any time, including the first
-- open. Thus, one should not use excessively large buffer sizes. With
-- respect to working set, under certain circumstances the buffer is used
-- in a cylic fashion. Thus, a large buffer size may cause a large
-- working set. All in all, its a good idea to use reasonable buffer
-- sizes. One rule of thumb is to use a buffer of size 2 * N * E, where
-- "N" is the number of servers (readers), and "E" is the expected message
-- size; this tends to leave just enough room for writers to be "double
-- bufferred". (Of course, the buffer must be large enough to hold the
-- biggest message.)
-- Given variable length messages, it is not possible for clients to
-- accurately predict the number of messages that can be stored by a buffer
-- of a particular size.
-- A pipe is made empty when it is last closed, or first opened if the
-- system crashes while the pipe is open. The only difference from the
-- user's point of view is disk space consumption.
-- The create operation leaves the pipe "open" in the specified mode.
-- Rules for Action are the same as for Open.
-- Abandoning the action may cause the object to dissappear from the
-- directory system.
-- Abandoning/Committing the action causes all open handles (using the
-- action) to become closed.
-- If Null_Action_Id is supplied, a new action is created. If the Create
-- is successful, the new id is stored in the Handle, and committed when
-- the Handle is closed. If the Create fails, the new action is
-- abandoned.
-- Reader_Buffer_Size controls the operation of the Read function. If 0,
-- then it defaults to the result of calling Max_Buffer_Size.
-- KNOWN BUGS IN DELTA: (1) Abandoning the action which created the pipe
-- does NOT cause all open handles to become closed immediately. (2) The
-- implementation has a window in which concurrent opens may acquire the
-- object; this will cause the Create to return any of the exceptions that
-- can be returned by Open.
-- EXCEPTIONS:
-- Status_Error: The given Handle is already open
-- Mode_Error: Mode must be Exclusive
-- Name_Error: Directory wont create the object
-- Use_Error: Illegal buffer size, or lock error, or
-- access control violation
-- Device_Error: Obj Mgr can't set/get the buffer size;
-- and other internal errors
procedure Open (Pipe : in out Handle;
Mode : Pipe_Open_Mode;
Name : String;
Reader_Buffer_Size : Natural := 0;
Action : Action_Id := Null_Action_Id;
Max_Wait : Duration := Directory.Default_Wait);
-- Open an already existing pipe.
-- If the action is abandoned, the Handle may become implicitly closed.
-- Committing the action has no effect on the state of the pipe buffer.
-- If Null_Action_Id is supplied, a new action is created, its id stored
-- in the Handle, and the action is committed when the Handle is closed.
-- Reader_Buffer_Size controls the operation of the Read function. If 0,
-- then it defaults to the result of calling Max_Buffer_Size.
-- KNOWN BUG IN DELTA: Exclusive access shows up in the action_manager's
-- lock information as "Update"; all other access modes show up as "Read".
-- EXCEPTIONS:
-- Status_error : The given Handle is already open.
-- Mode_Error: Mode must be Shared_Read, Shared_Write, or Exclusive
-- Name_Error: Directory can't find the object
-- Use_Error: Lock error, or access control violation
-- Device_Error: Obj mgr can't get the buffer size;
-- and other internal errors
procedure Open (Pipe : in out Handle;
Mode : Pipe_Open_Mode;
Object : Object_Id;
Reader_Buffer_Size : Natural := 0;
Action : Action_Id := Null_Action_Id;
Max_Wait : Duration := Directory.Default_Wait);
-- Same as above, but assumes that the caller has already resolved the
-- string name into an object id.
procedure Close (Pipe : in out Handle;
Max_Wait : Duration := Directory.Default_Wait);
-- If the pipe is open for writing, causes an implicit call to
-- Write_End_Of_File (throwing away a Use_Error caused by Max_Wait
-- induced timeout);
-- If the corresponding Create/Open supplied Null_Action_Id, then the
-- implicit action is either committed (when the Close is successful) or
-- abandoned (when the Close is unsuccessful).
-- The handle becomes closed.
-- EXCEPTIONS:
-- Status_error: The given Handle is not open.
-- Device_Error: internal errors
procedure Delete (Pipe : in out Handle;
Max_Wait : Duration := Directory.Default_Wait);
-- Like all objects, causes it to be deleted. Must have the object open
-- for Exclusive access. Assuming a reasonable value for retention count,
-- the object can be "undeleted" using other environment operations.
-- If the corresponding Create/Open supplied Null_Action_Id, then the
-- implicit action is either committed (when the Delete is successful) or
-- abandoned (when the Delete is unsuccessful).
-- The handle becomes closed.
-- EXCEPTIONS:
-- Status_Error: The given Handle is not open
-- Name_Error: Directory returned an error other than Lock_Error or
-- access control error
-- Use_Error: Directory returned Lock_Error, which probably means
-- that Handle was not open for Exclusive access;
-- or could be an access control violation
-- Device_Error: internal errors
Dont_Wait : constant Duration := 0.0;
Forever : constant Duration := Duration'Last;
procedure Write (Pipe : in out Handle;
Message : Byte_String;
Max_Wait : Duration := Forever);
procedure Read (Pipe : in out Handle;
Message : out Byte_String;
Length : out Integer;
Max_Wait : Duration := Forever);
function Read (Pipe : Handle; Max_Wait : Duration := Forever)
return Byte_String;
-- These operations are "record (message) oriented". That is, the write
-- operation puts one record into the pipe which remembers the record and
-- its length. When successful, the read operation reads exactly one
-- record (when unsuccessful, it reads 0 records), the Length out parameter
-- indicates the actual length of the record (as given by the corresponding
-- Write operation).
-- This is in contrast with the Device_Independent_Io (Dio) Byte_String
-- operations which are "stream oriented". That is, the read operation
-- returns exactly the number of bytes that are requested, unless
-- end-of-file is reached, in which case fewer bytes are returned, as
-- indicated by the Length out parameter.
-- Given that pipes are record oriented, it is possible to write a program
-- which reads messages from a pipe, and copies them or sends them
-- somewhere else, without regard for the actual type of the data, and
-- preserving message boundaries.
-- The Read function is the same as the Read procedure except that it
-- internally allocates a Byte_String (of the length specified by the
-- Reader_Buffer_Size parameter of Create/Open) in which to read the
-- message, and then returns the first Length bytes. For variable length
-- messages, this frees the client (of this package) from needing to know
-- the maximum message size. In the current implementation, this
-- convenience is not free: the function makes an additional copy of the
-- message (as compared to the procedure), and it allocates
-- Reader_Buffer_Size - Length extra bytes in its stack frame. Of course,
-- if the function call site simply assigns the result into some variable,
-- there is an additional copy (as compared to the procedure).
-- Read and Write operations are atomic with respect to each other. BUT,
-- This DOES NOT include multiple tasks reading/writing with the same
-- Handle.
-- Messages are passed by value. That is, once Write completes, the entire
-- message is stored within the pipe. Termination of the client (which
-- performed the Write) does not effect the state of the pipe.
-- Recall that a pipe has finite internal buffer capability. A Write
-- operation which would exceed the maximum buffer size (defined at pipe
-- creation time) always raises Use_Error (and extended status
-- Item_Too_Big). A Write operation which would exceed the remaining
-- buffer capacity is handled as follows: If Max_Wait time expires before
-- sufficient room becomes available in the buffer (this is immediately
-- true if Max_Wait = Dont_Wait), then raises Use_Error (and extended
-- status No_Room_In_Buffer). When Use_Error is raised, the pipe is left
-- unmodified (except for overrun notification, as discussed below). The
-- client can distinguish between these flavors of Use_Error via the
-- Get_Extended_Status operation, below.
-- In the event that there are multiple clients waiting to do Write, they
-- are typically serviced FIFO in order to avoid starvation.
-- Similarly, a Read operation specifies the maximum amount of time to
-- wait for the buffer to become non-empty. A time of 0 indicates that the
-- client does not want to wait at all. If the wait time expires before a
-- message is received by the client, then the client gets Use_Error, and
-- the pipe is left unchanged.
-- The Read operation returns a single message. The Length parameter
-- indicates the actual number of bytes written into the Message parameter.
-- In the event that the actual message (supplied by the corresponding
-- Write operation) was longer than the Message parameter supplied to Read,
-- the client will receive Data_Error (and extended status of
-- Item_Too_Big), and the contents of the pipe are left unchanged. In
-- future implementations, negative values of Length may be defined.
-- Recall that each message is read by exactly one Read operation; thus, in
-- the face of concurrent Reads, each client may see just a subset of the
-- messages that were written to the pipe.
-- In the event that there are multiple clients waiting to do Read, they
-- are typically serviced LIFO. We assume that the application considers
-- all readers to be equivalent. In this context, LIFO is better than FIFO
-- because it minimizes the working set of the readers. (LIFO causes the
-- reader which most recently finished working to be the next to receive a
-- message). This simplifies applications which need to choose the number
-- of readers; they can simply pick the maximum number of readers which can
-- operate in parallel.
-- The implementation of Read and Write waiting can handle aborts of
-- clients.
-- Specifying infinite wait times allows one to use the finite buffer
-- capacity as a flow control mechanism.
-- "end of file" (eof) messages are written into a pipe via the
-- Write_End_Of_File operation, and implicitly via Close (which itself may
-- be implicit via action abandon, which itself may be implicit ...). When
-- a Read operation encounters an eof message, it is consumed, and
-- End_Error is raised. Unlike other sequential media, one can read an
-- eof only once.
-- "Overrun" refers to a situation in which the writer does not wait
-- forever for buffer space to become available and drops the unsent
-- messages on the floor. Pipes include the following mechanism for
-- detecting overrun:
-- In addition to messages of type data and eof, there are messages of type
-- overrun. A Write operation which raises Use_Error (because there is
-- insufficient room in the buffer) appends a message of type overrun.
-- Adjacent overrun messages are coalesced into a single overrun message.
-- The Read operation consumes the overrun message (when encountered) and
-- raises Use_Error. Like eof, an overrun message can only be read once.
-- Death of a client that has the pipe open for update may sometimes cause
-- an overrun to be placed in the pipe.
-- Observations: (1) The writer should probably not "poll" the pipe by
-- using a short Max_Wait, since each unsuccessful attempt will append an
-- overrun message, causing the reader to get a Use_Error. (2) The reader
-- can distinguish between timeout and overrun (both raise Use_Error) by
-- using the Extended_Status function, below.
-- EXCEPTIONS:
-- Status_Error : The given Handle is not open
-- Mode_Error : Write: Handle was Open'd for Exclusive_Read
-- or Shared_Read
-- Read: Handle was Open'd for Exclusive_Write
-- or Shared_Write
-- Use_Error : Write: Max_Wait expired,
-- or Message'length is larger than buffer size;
-- Read: Max_Wait expired,
-- or just consumed an overrun message
-- Data_Error : Read: Message'length is shorter than next message
-- : Read/Write: touching Message caused
-- Nonexistant_Page_Error
-- : Read: storing into Message caused
-- Write_To_Read_Only_Page
-- End_Error : Read: just consumed an end-of-file message
-- Device_Error : internal errors
pragma Consume_Offset (4);
generic
type Element_Type is private;
package Type_Specific_Operations is
procedure Write (Pipe : in out Handle;
Message : Element_Type;
Max_Wait : Duration := Forever);
procedure Read (Pipe : in out Handle;
Message : out Element_Type;
Max_Wait : Duration := Forever);
function Read (Pipe : Handle; Max_Wait : Duration := Forever)
return Element_Type;
pragma Consume_Offset;
end Type_Specific_Operations;
-- The usual "legal type for IO" rules apply to Element_Type. In
-- particular, Element_Type cannot be (or contain) pointers or tasks.
-- Both ends of the pipe should instantiate this package with the same
-- type, else one will get implicit unchecked conversions, and might
-- get Data_Error.
-- The generic Write operation first normalizes the Message, converts the
-- bits (of the Message) into a Byte_String (adding up to 7 bits of
-- padding, as necessary), and then calls the non-generic Write.
-- By normalize, we mean the following. For record types, if the object is
-- not constrained, allocate a constained instance of the object and copy
-- the Message into the constrained copy. Note that this is expensive,
-- since it involves declaring collections and doing copies. For array
-- types, if the "bounds with object"ness of the Message is not the same as
-- that of the Element_Type (argument to the generic), then a copy is made
-- to convert the Message to the same boundedness as the Element_Type.
-- The generic Read procedure calls the non-generic Read procedure to fetch
-- the padded Byte_String, does an implicit unchecked conversion to
-- Element_Type, and assigns it to the out parameter.
-- The conversion may cause Data_Error to be raised when Element_Type is
-- not "compatable" with the actual bits in the message; this might happen
-- if the Write generic was instantiated with a different type than the
-- Read generic, for example. Some conditions that may cause
-- incompatibility: The 'size of the result of the unchecked conversion
-- (rounded to a byte) is not the same as the actual byte length of the
-- received message. The Element_Type is unconstrained and the message is
-- garbage (when interpreted according to Element_Type).
-- The assignment follows Ada semantics, and may therefore fail for a
-- variety of reasons, causing Data_Error. Some conditions that may cause
-- the assignment to fail: Element_Type is an unconstrained array type
-- (such as String), and the 'length of the string value in the buffer is
-- not the same as the 'length of the Message out parameter. The
-- Element_Type is unconstrained and the message is garbage (when
-- interpreted according to Element_Type).
-- The generic Read function calls the non-generic Read function, does an
-- implicit unchecked conversion to Element_Type, and returns the result.
-- Data_Error may be raised when Element_Type is not "compatible" with the
-- actual bits in the message, as for the Read procedure.
-- EXCEPTIONS (in addition to those raised by the non-generic forms):
-- Data_Error : Read: bits in the actual message are not
-- "compatible" with Element_Type, or := failed.
-- Pkg instantiation: raised when Element_Type has
-- task or access/heap_access components.
function End_Of_File (Pipe : Handle) return Boolean;
-- Returns true iff a read operation would have caused End_Error to be
-- raised.
-- EXCEPTIONS:
-- Status_Error : The given Handle is not open
-- Device_Error : internal errors
procedure Write_End_Of_File (Pipe : in out Handle;
Max_Wait : Duration := Forever);
-- Puts an end-of-file message into the pipe. Note that Close (of a pipe
-- open for writing) may implicitly call this procedure. Abandoning
-- an action (of a writer) may implicitly call this procedure. With
-- respect to overruns, this call follows rules given for Write.
-- EXCEPTIONS:
-- Status_Error : The given Handle is not open
-- Use_Error : Max_Wait expired,
-- or Message'length is larger than buffer size;
-- Device_Error : internal errors
function Current_Message_Count (Pipe : Handle) return Natural;
-- Can be used to "poll" a pipe to see how many messages are queued up,
-- waiting to be read.
-- EXCEPTIONS:
-- Status_Error : The given Handle is not open
function Max_Buffer_Size (Pipe : Handle) return Positive;
-- Return the buffer size of an open pipe.
-- EXCEPTIONS:
-- Status_Error : The given Handle is not open
function Open_Action (Pipe : Handle) return Action_Id;
-- Returns the action by which the Handle has the pipe open.
-- EXCEPTIONS:
-- Status_Error : The given Handle is not open
pragma Consume_Offset (3);
type Full_Status_Kinds is
(Pipe_Status, Directory_Error_Status,
Directory_Name_Status, Manager_Status, U4, U5, U6, U7);
function Get_Full_Status_Kind (Pipe : Handle) return Full_Status_Kinds;
-- Defined iff the Handle is currently open and the last PROCEDURE call on
-- the Handle raised an exception and the following table indicates that
-- additional status is available.
-- Status_Error no additional status
-- Mode_Error no additional status
-- Name_Error more status available
-- Use_Error more status available
-- Device_Error more status available
-- End_Error more status available
-- Data_Error more status available
-- Layout_Error no additional status In this case, indicates which
-- kind of additional status information is available about the exception.
type Extended_Status is (Internal_Pipe_Error, Item_Too_Big,
No_Room_In_Buffer, Buffer_Is_Empty,
Behind_Other_Readers, Read_An_Eof, Read_An_Overrun,
Missing_Page, Read_Only_Page, U09,
U10, U11, U12, U13, U14, U15, U16);
function Get_Extended_Status (Pipe : Handle) return Extended_Status;
function Get_Directory_Error_Status (Pipe : Handle) return Integer;
function Get_Directory_Name_Status (Pipe : Handle) return Integer;
function Get_Manager_Status (Pipe : Handle) return Operate_Status;
-- The above are defined iff Get_Full_Status_Kind is defined and returns
-- the corresponding value of Full_Status_Kinds. Rational reserves the
-- right to add additional Extended_Status values. Otherwise, it's ok
-- to program against Extended_Status values. The integer values returned
-- by the last 3 functions are for debugging only, and may change between
-- between releases of this software.
function Status_Explanation (Pipe : Handle) return String;
-- Returns, in string form, the best explanation of the status that is
-- currently available. This explanation may include additional internal
-- state information. The returned string may differ between releases of
-- this software.
generic
with procedure Put_Line (S : String);
procedure Put_Pipe_Internal_State (Pipe : Handle;
Depth : Natural := 25;
Get_Locks : Boolean := False);
generic
with procedure Put_Line (S : String);
procedure Put_Internal_State (Depth : Natural := 25;
Get_Locks : Boolean := False);
-- These operations are primarily intended for use as debugging
-- aids by Rational personnel. However, it is also possible for customers
-- to use this information to debug their applications. The format of the
-- of the information fed through Put_Line may change in future releases.
-- The first operation gives you more information if the Handle is for an
-- open pipe! Depth is used to keep various algorithms from going into an
-- infinite loop when the internal data structures for the pipe are
-- inconsistent. Get_Locks indicates whether or not the internal data
-- structures should be viewed from within the appropriate critical
-- regions; in the current implementation, only the default is supported.
-- These operations are primarily intended for use as debugging
-- aids by Rational personnel. However, it is also possible for customers
-- to use this information to debug their applications. The format of the
-- of the information fed through Put_Line may change in future releases.
-- The first operation gives you more information if the Handle is for an
-- open pipe! Depth is used to keep various algorithms from going into an
-- infinite loop when the internal data structures for the pipe are
-- inconsistent. Get_Locks indicates whether or not the internal data
-- structures should be viewed from within the appropriate critical
-- regions; in the current implementation, only the default is supported.
function Debug_Image (Pipe : Handle;
Level : Natural;
Prefix : String;
Expand_Pointers : Boolean) return String;
--
-- Daemon control. The interval specifies how often the pipe daemon
-- runs. It defaults to every 30 seconds at low CPU priority.
--
-- Run_Daemon will cause the daemon to run at the priority of the
-- calling task. Note that this might actually cause the daemon
-- to run twice if it is currently scheduled and blocked, since it
-- has to finish (at the low priority) before this call can run it.
function Get_Daemon_Interval return Duration;
procedure Set_Daemon_Interval (Interval : Duration);
procedure Run_Daemon;
pragma Subsystem (Input_Output, Private_Part => Closed);
pragma Module_Name (4, 3223);
end Pipe;with Action;
with Default;
with Directory;
with Io_Exceptions;
with System;
package Polymorphic_Io is
pragma Subsystem (Directory);
pragma Module_Name (4, 1706);
-- Provides the basic file abstraction on top of the package directory
-- and file object manager abstractions. Understanding actions is not
-- necessary to use this level; parameters are always defaulted to be
-- single, queued actions. Intended users are the Ada LRM Chapter 14
-- IO packages, as well as sophisticated users that require more facilities
-- than those provided in Chapter 14.
subtype File is Directory.Object;
subtype Version is Directory.Version;
function Get_Class return Directory.Class;
subtype Error_Status is Directory.Error_Status;
type Handle is limited private;
-- Handle that is needed to do anything to a file.
function Nil return Handle;
function Is_Nil (File : Handle) return Boolean;
type File_Mode is (Read_Only, Write_Only, Read_Write, None);
type File_Position is private;
-- Logical file pointer that is needed to input and output operations.
function Nil return File_Position;
function First return File_Position;
function Is_Nil (Position : File_Position) return Boolean;
function Is_First (Position : File_Position) return Boolean;
function "<" (Left, Right : File_Position) return Boolean;
function "<=" (Left, Right : File_Position) return Boolean;
function ">" (Left, Right : File_Position) return Boolean;
function ">=" (Left, Right : File_Position) return Boolean;
package Naming renames Directory.Naming;
subtype Context is Directory.Naming.Context;
function Default_Context
(For_Job : Default.Process_Id := Default.Process) return Context
renames Directory.Naming.Default_Context;
procedure Open (The_Handle : in out Handle;
Mode : File_Mode;
File_Name : Naming.Name;
Status : out Error_Status;
The_Version : Directory.Version_Name :=
Directory.Default_Version;
The_Context : Context := Polymorphic_Io.Default_Context;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Directory.Default_Wait;
Prevent_Backup : Boolean := False);
procedure Open (The_Handle : in out Handle;
Mode : File_Mode;
The_Object : File;
Status : out Error_Status;
The_Version : Directory.Version_Name :=
Directory.Default_Version;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Directory.Default_Wait;
Prevent_Backup : Boolean := False);
procedure Open (The_Handle : in out Handle;
Mode : File_Mode;
The_Version : in out Version;
Status : out Error_Status;
Action_Id : Action.Id := Action.Null_Id;
Max_Wait : Duration := Directory.Default_Wait;
Prevent_Backup : Boolean := False);
procedure Close (File : in out Handle; Status : out Error_Status);
-- Close a previously opened File.
procedure Delete (File : in out Handle; Status : out Error_Status);
-- Delete a previously opened File. File cannot have been opened for Read.
-- Commit any action opened on behalf of the user
function Is_Open (File : Handle) return Boolean;
function Mode (File : Handle) return File_Mode;
function Name (File : Handle) return Naming.Simple_Name;
function Full_Name (File : Handle) return Naming.Name;
-- Extract information about an open File.
function End_Of_File
(File : Handle; Position : File_Position) return Boolean;
-- TRUE => Position is past end_of_File
function First_Free_Position (File : Handle) return File_Position;
-- Determine the first free (ie. non-existent) position within File.
function Size (File : Handle) return Long_Integer;
-- size of file in bits
generic
type Element is private;
-- Element must be constrained and "safe".
package Direct_Operations is
function Compute (In_File : Handle;
Index : Positive;
Base : File_Position := Polymorphic_Io.First)
return File_Position;
-- Determine the File_Position of the Index'th Element past Base.
function Read (From_File : Handle; At_Position : File_Position)
return Element;
-- Yield the Element at the specified position in From_File.
-- If At_Position >= Free (From_File), END_ERROR is raised.
-- If the system can detect that no element has ever been
-- written At_Position, HOLE_ERROR is raised.
procedure Write (To_File : Handle;
At_Position : File_Position;
Value : Element);
-- Store the Value at the specified position in To_File.
-- If At_Position + Value'Size >= Free (To_File), To_File is
-- extended so that Free (To_File) = At_Position + Value'Size.
end Direct_Operations;
generic
type Element is private;
-- must be "safe"
package Sequential_Operations is
function Next (In_File : Handle; After : File_Position)
return File_Position;
-- Move to the next Element in the specified file beyond After.
-- If After >= Free (In_File), END_ERROR is raised.
function Read (From_File : Handle; At_Position : File_Position)
return Element;
-- Yield the Element at the specified position in From_File.
-- If At_Position >= Free (From_File), END_ERROR is raised.
-- If the system can detect that no element has ever been
-- written At_Position, HOLE_ERROR is raised.
procedure Write (To_File : Handle;
At_Position : File_Position;
Value : Element);
-- Store the Value at the specified position in To_File.
-- If At_Position + Value'Size >= Free (To_File), To_File is
-- extended so that Free (To_File) = At_Position + Value'Size.
end Sequential_Operations;
generic
type Element is private;
type Element_Pointer is access Element;
pragma Segmented_Heap (Element_Pointer);
package Access_Operations is
function Reference (From_File : Handle; At_Position : File_Position)
return Element_Pointer;
-- return a reference to the element "at_position"
function Position (From_File : Handle; Pointer : Element_Pointer)
return File_Position;
-- return position of element referenced by Pointer.
end Access_Operations;
Status_Error : exception renames Io_Exceptions.Status_Error;
Mode_Error : exception renames Io_Exceptions.Mode_Error;
End_Error : exception renames Io_Exceptions.End_Error;
Data_Error : exception renames Io_Exceptions.Data_Error;
----------------------------------------------
-- CONVERSION OPERATIONS for FILE_POSITIONS --
----------------------------------------------
function Convert (Pos : File_Position) return Long_Integer;
function Convert (Pos : Long_Integer) return File_Position;
procedure Save (File : in out Handle;
Status : out Error_Status;
Immediate_Effect : Boolean := False);
function Get_Action (File : Handle) return Action.Id;
package String_Operations is
subtype Byte is System.Byte;
subtype Byte_String is System.Byte_String;
procedure Read (File : Handle;
Pos : in out File_Position;
Item : out Byte_String;
Count : out Natural);
procedure Read (File : Handle;
Pos : in out File_Position;
Item : out Byte);
procedure Read (File : Handle;
Pos : in out File_Position;
Item : out String;
Count : out Natural);
procedure Read (File : Handle;
Pos : in out File_Position;
Item : out Character);
procedure Write (File : Handle;
Pos : in out File_Position;
Item : Byte_String);
procedure Write
(File : Handle; Pos : in out File_Position; Item : Byte);
procedure Write
(File : Handle; Pos : in out File_Position; Item : String);
procedure Write (File : Handle;
Pos : in out File_Position;
Item : Character);
end String_Operations;
procedure Truncate (File : Handle;
Pos : File_Position := Polymorphic_Io.First);
-- Shortens the file so that Pos is the first position outside the file.
-- Will not make the file bigger if Pos is larger than the current size of
-- the file.
end Polymorphic_Io;with Io_Exceptions;
with Device_Independent_Io;
package Polymorphic_Sequential_Io is
pragma Subsystem (Input_Output);
pragma Module_Name (4, 3210);
type File_Type is limited private;
type File_Mode is (In_File, Out_File);
-- File management
procedure Create (File : in out File_Type;
Mode : File_Mode := Out_File;
Name : String := "";
Form : String := "");
procedure Open (File : in out File_Type;
Mode : File_Mode;
Name : String;
Form : String := "");
procedure Close (File : in out File_Type);
procedure Delete (File : in out File_Type);
procedure Reset (File : in out File_Type; Mode : File_Mode);
procedure Reset (File : in out File_Type);
function Mode (File : File_Type) return File_Mode;
function Name (File : File_Type) return String;
function Form (File : File_Type) return String;
function Is_Open (File : File_Type) return Boolean;
-- Input and output operations
generic
type Element_Type is private;
package Operations is
procedure Read (File : File_Type; Item : out Element_Type);
procedure Write (File : File_Type; Item : Element_Type);
end Operations;
function End_Of_File (File : File_Type) return Boolean;
procedure Append
(File : in out File_Type; Name : String; Form : String := "");
-- Exceptions
Status_Error : exception renames Io_Exceptions.Status_Error;
Mode_Error : exception renames Io_Exceptions.Mode_Error;
Name_Error : exception renames Io_Exceptions.Name_Error;
Use_Error : exception renames Io_Exceptions.Use_Error;
Device_Error : exception renames Io_Exceptions.Device_Error;
End_Error : exception renames Io_Exceptions.End_Error;
Data_Error : exception renames Io_Exceptions.Data_Error;
end Polymorphic_Sequential_Io;with Io_Exceptions;
with Device_Independent_Io;
generic
type Element_Type is private;
package Sequential_Io is
pragma Subsystem (Input_Output);
pragma Module_Name (4, 3204);
type File_Type is limited private;
type File_Mode is (In_File, Out_File);
-- File management
procedure Create (File : in out File_Type;
Mode : File_Mode := Out_File;
Name : String := "";
Form : String := "");
procedure Open (File : in out File_Type;
Mode : File_Mode;
Name : String;
Form : String := "");
procedure Close (File : in out File_Type);
procedure Delete (File : in out File_Type);
procedure Reset (File : in out File_Type; Mode : File_Mode);
procedure Reset (File : in out File_Type);
function Mode (File : File_Type) return File_Mode;
function Name (File : File_Type) return String;
function Form (File : File_Type) return String;
function Is_Open (File : File_Type) return Boolean;
-- Input and output operations
procedure Read (File : File_Type; Item : out Element_Type);
procedure Write (File : File_Type; Item : Element_Type);
function End_Of_File (File : File_Type) return Boolean;
-- Exceptions
Status_Error : exception renames Io_Exceptions.Status_Error;
Mode_Error : exception renames Io_Exceptions.Mode_Error;
Name_Error : exception renames Io_Exceptions.Name_Error;
Use_Error : exception renames Io_Exceptions.Use_Error;
Device_Error : exception renames Io_Exceptions.Device_Error;
End_Error : exception renames Io_Exceptions.End_Error;
Data_Error : exception renames Io_Exceptions.Data_Error;
private
type File_Type is new Device_Independent_Io.File_Type;
end Sequential_Io;with Device_Independent_Io;
with System;
package Tape_Specific is
subtype File_Type is Device_Independent_Io.File_Type;
subtype Byte_Range is Natural range 0 .. 4096;
subtype Pipe_Range is Natural range 0 .. 8;
subtype Byte_String is System.Byte_String;
type On_Off is (On, Off);
procedure Set_Block_Size (File : File_Type; Size : Byte_Range);
-- default is Recommended_Max_Block_Length
procedure Set_Streaming_Mode (File : File_Type; Mode : On_Off);
-- on = true turns streaming mode on
-- on = false turns streaming mode off
-- default is off
procedure Set_Pipeline_Size (File : File_Type; Size : Pipe_Range);
-- pipeline size to use if in streaming mode
-- default is Recommended_Pipeline_Size
procedure Unload (File : File_Type);
-- the "file" is closed
-- the tape drive unloads the tape
procedure Rewind (File : File_Type);
-- the tape is put at beginning of tape
type Skip_Records_Obstacles is
(None, -- No obstacle encountered
Tape_Mark, -- Tape mark encountered,
Bot -- Beginning of tape was encountered while
-- while skipping backwards
);
type Skip_Marks_Obstacles is
(None, -- No obstacle encountered
Double_Tape_Mark, -- 2 consecutive tape marks were encountered
-- while skipping forward
Bot -- Beginning of tape was encountered while
-- while skipping backwards
);
type Error_Status is
(Success, -- No error encountered
Record_Length_Long, -- Record on tape was longer than parameter
Not_On_Line, -- Drive was offline
Retry_Count_Exhausted, -- Record/tape mark can't be read/written
Unexpected_Tape_Error, -- Tape position lost, rewind or unload it
Unit_Is_Bad); -- Call Field Service
-- The following procedures that do not return an error status will have
-- the exception DATA_ERROR raised if RECORD_LENGTH_LONG would have been
-- returned. DEVICE_ERROR is raised for all other non-SUCCESS statuses.
procedure Unload (File : File_Type; Status : out Error_Status);
-- the "file" is closed
-- the tape drive unloads the tape
procedure Rewind (File : File_Type; Status : out Error_Status);
-- the tape is put at beginning of tape
-- The following should NOT be intermingled with the Read and Write
-- procedures in Device_Independent_IO for the same file.
-- The READ procedures return the next record of data on the tape.
-- COUNT returns the actual size of the physical tape record in bytes.
-- Only the first COUNT elements of RECRD are valid.
-- If RECORD_LENGTH_LONG is returned as the error status, then RECRD
-- contains the first RECRD'LENGTH bytes of the physical tape record and
-- COUNT = RECRD'LENGTH. If a tape mark was read, then COUNT = 0.
procedure Read (File : File_Type;
Recrd : out Byte_String;
Count : out Natural);
procedure Read (File : File_Type;
Recrd : out Byte_String;
Count : out Natural;
Status : out Error_Status);
procedure Read (File : File_Type; Recrd : out String; Count : out Natural);
procedure Read (File : File_Type;
Recrd : out String;
Count : out Natural;
Status : out Error_Status);
-- The two IS_MARK subprograms return whether the next tape record to be
-- read is a tape mark. These subprograms should only be used while in
-- streaming mode otherwise they will raise USE_ERROR. They will raise
-- MODE_ERROR if the file is not open for input.
function Is_Mark (File : File_Type) return Boolean;
procedure Is_Mark (File : File_Type;
Result : out Boolean;
Status : out Error_Status);
-- The WRITE procedures write the contents of RECRD on the tape as a
-- physical tape record. RECRD'LENGTH must be greater than or equal to 18
-- and less than or equal to the ABSOLUTE_MAX_BLOCK_LENGTH (currently
-- 4096) otherwise USE_ERROR will be raised.
-- PAST_EOT_MARKER indicates that the area beyond the reflective EOT marker
-- on the tape is now being written. Users are cautioned that tape
-- standards specify that there is at least 25 ft. of tape from the marker
-- to the end of the reel, but only the first 10 ft. are useable. It
-- is OK to write in this 10 ft. area but writing beyond that runs the
-- risk of running the tape off its reel.
procedure Write (File : File_Type;
Recrd : Byte_String;
Past_Eot_Marker : out Boolean);
procedure Write (File : File_Type;
Recrd : Byte_String;
Past_Eot_Marker : out Boolean;
Status : out Error_Status);
procedure Write (File : File_Type;
Recrd : String;
Past_Eot_Marker : out Boolean);
procedure Write (File : File_Type;
Recrd : String;
Past_Eot_Marker : out Boolean;
Status : out Error_Status);
-- The WRITE_MARK procedures cause a tape mark to be written to the tape.
procedure Write_Mark (File : File_Type; Past_Eot_Marker : out Boolean);
procedure Write_Mark (File : File_Type;
Past_Eot_Marker : out Boolean;
Status : out Error_Status);
-- The SKIP_RECORDS procedures position the tape either forward
-- or backward until ABS (NUM_RECORDS_TO_SKIP) have been skipped or
-- an obstacle has been encountered. A positive NUM_RECORDS_TO_SKIP
-- implies skipping forward; negative implies skipping backward; zero
-- implies no movement. If a tape mark is encountered as an obstacle,
-- the position of the tape is on the "other side" of the tape mark; i.e.,
-- when skipping backward, the next item read would be that same tape mark
-- or when skipping forward, the next item read would be the record or
-- tape mark beyond the obstacle tape mark. The RECORDS_SKIPPED does
-- not include the tape mark. If the Beginning-Of-Tape reflective marker
-- is encountered while skipping backward, the position of the tape will
-- be at the beginning of the tape, ready to read the first record.
-- MODE_ERROR is raised if the file is not open for reading. USE_ERROR
-- is raised if the file is in streaming mode.
procedure Skip_Records (File : File_Type;
Num_Records_To_Skip : Integer;
Obstacle : out Skip_Records_Obstacles;
Records_Skipped : out Natural);
procedure Skip_Records (File : File_Type;
Num_Records_To_Skip : Integer;
Obstacle : out Skip_Records_Obstacles;
Records_Skipped : out Natural;
Status : out Error_Status);
-- The SKIP_TAPE_MARKS procedures position the tape either forward or
-- backward until ABS (NUM_MARKS_TO_SKIP) have been skipped or
-- an obstacle has been encountered. A positive NUM_MARKS_TO_SKIP
-- implies skipping forward; negative implies skipping backward; zero
-- implies no movement. Two consecutive tape marks (a double tape mark)
-- is only an obstacle while skipping forward; in which case neither of
-- the tape marks is counted in MARKS_SKIPPED. If two consecutive tape
-- marks are encountered while skipping backward, it is not an obstacle
-- and they are treated as individual tape marks in MARKS_SKIPPED. If
-- the Beginning-Of-Tape reflective marker is encountered while skipping
-- backward, the position of the tape will be at the beginning of the
-- tape, ready to read the first record. If no obstacle was encountered,
-- the position of the tape is on the "other side" of the last tape mark.
-- MODE_ERROR is raised if the file is not open for reading. USE_ERROR
-- is raised if the file is in streaming mode.
procedure Skip_Tape_Marks (File : File_Type;
Num_Marks_To_Skip : Integer;
Obstacle : out Skip_Marks_Obstacles;
Marks_Skipped : out Natural);
procedure Skip_Tape_Marks (File : File_Type;
Num_Marks_To_Skip : Integer;
Obstacle : out Skip_Marks_Obstacles;
Marks_Skipped : out Natural;
Status : out Error_Status);
pragma Subsystem (Input_Output);
pragma Module_Name (4, 3214);
end Tape_Specific;with Device_Independent_Io;
with System;
package Terminal_Specific is
-- This package supports operations that are specific to
-- "terminals". For this purpose, a terminal is an object of
-- type Terminal. These objects are in !Machine.Devices.
--
-- Normal Text_IO-style IO to the terminal is done through:
-- !USERS.user.session Standard_Output
-- !MACHINE.USERS.user Standard_Error
--
-- Window_IO provides quarter-plane, addressable display and key input
--
-- Access to the terminal for Standard_Output, Standard_Error and
-- Window_IO is handled by the job controlling the session, so there may
-- be multiple, simultaneously-active windows.
--
-- Opening a terminal directly provides the application complete control
-- of the terminal. In this case, the terminal is controlled by the job
-- that opens it, NOT the session job.
--
-- More than one job can have a terminal open at the same time, but
-- only one of them will actually receive input or transmit output.
-- Any others will be blocked on both input and output. A job that
-- references the terminal directly and simultaneously uses one of the
-- session-controlled forms of terminal interaction will not work well and
-- may deadlock.
--
-- Attempts to open an enabled terminal other than the one for
-- current session will fail. Control over enabled/disabled status
-- of terminals is available in the Operator package.
--
-- The determination of which of the various jobs dealing with the
-- terminal actually have the right to transmit/receive is done on
-- the basis of which job is "connected". There is at most one
-- connected job at any time. If a job that has the terminal open
-- is currently connected, it has the terminal. If it disconnects
-- or is terminated, control of the terminal reverts to the session.
-- The user can return control of the terminal to the application
-- by doing a Job.Connect with the appropriate job number.
--
-- Transfers of terminal ownership are detectable as part of the
-- status of the Read and Write operations. This allows
-- applications that support disconnect to detect when to redraw
-- their version of the screen.
--
-- The following device-specific Form options are supported:
--
-- Option Explanation Default
--
-- Echo whether to echo input True
-- Edit Line editing or None Line
-- CRLF map LF to CRLF True
--
-- Note: the CRLF option is ignored by the Write procedures in this
-- package to reduce confusion over whether the CR was transferred for a
-- particular count. CRLF is honored by device_independent write/put
-- operations.
--
subtype File_Type is Device_Independent_Io.File_Type;
subtype Byte_String is Device_Independent_Io.Byte_String;
package Status is
type Code is new Integer;
function Image (Value : Code) return String;
--
-- Status.Code Standard reaction
--
-- Normal none
-- Break raise End_Error
-- Disconnect raise End_Error
-- Timed_Out 0 data bytes transferred
-- Data_Error raise Data_Error
-- Data_Overrun raise Device_Error
-- Lost_Ownership ignored
-- Gained_Ownership ignored
-- Too_Many_Clients raise Device_Error
--
-- Standard Read/Write routines in Device_Independent_IO use:
-- Duration'Last for Wait parameters
-- "Standard Reaction" for Result parameters
--
Normal : constant Code := 0;
Break : constant Code := 1;
Disconnect : constant Code := 2;
Not_Open : constant Code := 3;
Timed_Out : constant Code := 4;
Data_Error : constant Code := 5;
Data_Overrun : constant Code := 6;
Lost_Ownership : constant Code := 7;
Gained_Ownership : constant Code := 8;
Too_Many_Clients : constant Code := 9;
end Status;
package Output is
procedure Map_Lf_To_Crlf (File : File_Type; Value : Boolean := True);
-- Equivalent of CRLF Form option; default True
procedure Transmit_Break (File : File_Type);
procedure Transmit_Break (File : File_Type;
Wait : Duration;
Result : out Status.Code);
procedure Disconnect (File : File_Type);
procedure Disconnect (File : File_Type;
Wait : Duration;
Result : out Status.Code);
procedure Wait_For_Transmission (File : File_Type);
-- Wait for all previously written data to be transmitted.
procedure Set_Rts (File : File_Type; On : Boolean);
-- Set the current state of the RTS (pin 4) RS-232
-- modem control output. True => ON, False => OFF.
procedure Set_Dtr (File : File_Type; On : Boolean);
-- Set the current state of the DTR (pin 20) RS-232
-- modem control output. True => ON, False => OFF.
end Output;
package Input is
procedure Flush (File : File_Type);
procedure Set_Echo (File : File_Type; Echo : Boolean := True);
-- Equivalent to Echo Form option; default True
function Get_Echo (File : File_Type) return Boolean;
procedure Set_Editing (File : File_Type; Mode : String := "Line");
-- Equivalent to the Edit Form option; default Edit => Line
-- Disabled with value None.
function Get_Editing (File : File_Type) return String;
end Input;
procedure Read (File : File_Type;
Item : out Byte_String;
Count : out Natural;
Wait : Duration);
procedure Read (File : File_Type;
Item : out String;
Count : out Natural;
Wait : Duration);
procedure Read (File : File_Type;
Item : out Byte_String;
Count : out Natural;
Wait : Duration;
Result : out Status.Code);
procedure Read (File : File_Type;
Item : out String;
Count : out Natural;
Wait : Duration;
Result : out Status.Code);
procedure Write (File : File_Type;
Item : Byte_String;
Count : out Natural;
Wait : Duration);
procedure Write (File : File_Type;
Item : String;
Count : out Natural;
Wait : Duration);
procedure Write (File : File_Type;
Item : Byte_String;
Count : out Natural;
Wait : Duration;
Result : out Status.Code);
procedure Write (File : File_Type;
Item : String;
Count : out Natural;
Wait : Duration;
Result : out Status.Code);
pragma Subsystem (Input_Output);
pragma Module_Name (4, 3215);
end Terminal_Specific;with Io_Exceptions;
package Text_Io is
pragma Subsystem (Input_Output, Private_Part => Closed);
pragma Module_Name (4, 3201);
type File_Type is limited private;
type File_Mode is (In_File, Out_File);
type Count is range 0 .. 1_000_000_000;
subtype Positive_Count is Count range 1 .. Count'Last;
Unbounded : constant Count := 0; -- line and page length
subtype Field is Integer range 0 .. Integer'Last;
subtype Number_Base is Integer range 2 .. 16;
type Type_Set is (Lower_Case, Upper_Case);
-- File Management
procedure Create (File : in out File_Type;
Mode : File_Mode := Out_File;
Name : String := "";
Form : String := "");
procedure Open (File : in out File_Type;
Mode : File_Mode;
Name : String;
Form : String := "");
procedure Close (File : in out File_Type);
procedure Delete (File : in out File_Type);
procedure Reset (File : in out File_Type; Mode : File_Mode);
procedure Reset (File : in out File_Type);
function Mode (File : File_Type) return File_Mode;
function Name (File : File_Type) return String;
function Form (File : File_Type) return String;
function Is_Open (File : File_Type) return Boolean;
-- Control of default input and output files
procedure Set_Input (File : File_Type);
procedure Set_Output (File : File_Type);
function Standard_Input return File_Type;
function Standard_Output return File_Type;
function Current_Input return File_Type;
function Current_Output return File_Type;
-- Specification of line and page lengths
procedure Set_Line_Length (File : File_Type; To : Count);
procedure Set_Line_Length (To : Count);
procedure Set_Page_Length (File : File_Type; To : Count);
procedure Set_Page_Length (To : Count);
function Line_Length (File : File_Type) return Count;
function Line_Length return Count;
function Page_Length (File : File_Type) return Count;
function Page_Length return Count;
-- Column, Line and Page Control
procedure New_Line (File : File_Type; Spacing : Positive_Count := 1);
procedure New_Line (Spacing : Positive_Count := 1);
procedure Skip_Line (File : File_Type; Spacing : Positive_Count := 1);
procedure Skip_Line (Spacing : Positive_Count := 1);
function End_Of_Line (File : File_Type) return Boolean;
function End_Of_Line return Boolean;
procedure New_Page (File : File_Type);
procedure New_Page;
procedure Skip_Page (File : File_Type);
procedure Skip_Page;
function End_Of_Page (File : File_Type) return Boolean;
function End_Of_Page return Boolean;
function End_Of_File (File : File_Type) return Boolean;
function End_Of_File return Boolean;
procedure Set_Col (File : File_Type; To : Positive_Count);
procedure Set_Col (To : Positive_Count);
procedure Set_Line (File : File_Type; To : Positive_Count);
procedure Set_Line (To : Positive_Count);
function Col (File : File_Type) return Positive_Count;
function Col return Positive_Count;
function Line (File : File_Type) return Positive_Count;
function Line return Positive_Count;
function Page (File : File_Type) return Positive_Count;
function Page return Positive_Count;
-- Character Input-Output
procedure Get (File : File_Type; Item : out Character);
procedure Get (Item : out Character);
procedure Put (File : File_Type; Item : Character);
procedure Put (Item : Character);
-- String Input-Output
procedure Get (File : File_Type; Item : out String);
procedure Get (Item : out String);
procedure Put (File : File_Type; Item : String);
procedure Put (Item : String);
procedure Get_Line
(File : File_Type; Item : out String; Last : out Natural);
procedure Get_Line (Item : out String; Last : out Natural);
procedure Put_Line (File : File_Type; Item : String);
procedure Put_Line (Item : String);
-- Generic package for Input-Output of Integer Types
generic
type Num is range <>;
package Integer_Io is
Default_Width : Field := Num'Width;
Default_Base : Number_Base := 10;
procedure Get (File : File_Type; Item : out Num; Width : Field := 0);
procedure Get (Item : out Num; Width : Field := 0);
procedure Put (File : File_Type;
Item : Num;
Width : Field := Default_Width;
Base : Number_Base := Default_Base);
procedure Put (Item : Num;
Width : Field := Default_Width;
Base : Number_Base := Default_Base);
procedure Get (From : String; Item : out Num; Last : out Positive);
procedure Put (To : out String;
Item : Num;
Base : Number_Base := Default_Base);
end Integer_Io;
-- Generic package for Input-Output of Floating Point Types
generic
type Num is digits <>;
package Float_Io is
Default_Fore : Field := 2;
Default_Aft : Field := Num'Digits - 1;
Default_Exp : Field := 3;
procedure Get (File : File_Type; Item : out Num; Width : Field := 0);
procedure Get (Item : out Num; Width : Field := 0);
procedure Put (File : File_Type;
Item : Num;
Fore : Field := Default_Fore;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
procedure Put (Item : Num;
Fore : Field := Default_Fore;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
procedure Get (From : String; Item : out Num; Last : out Positive);
procedure Put (To : out String;
Item : Num;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
end Float_Io;
-- Generic package for Input-Output of Fixed Point Types
generic
type Num is delta <>;
package Fixed_Io is
Default_Fore : Field := Num'Fore;
Default_Aft : Field := Num'Aft;
Default_Exp : Field := 0;
procedure Get (File : File_Type; Item : out Num; Width : Field := 0);
procedure Get (Item : out Num; Width : Field := 0);
procedure Put (File : File_Type;
Item : Num;
Fore : Field := Default_Fore;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
procedure Put (Item : Num;
Fore : Field := Default_Fore;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
procedure Get (From : String; Item : out Num; Last : out Positive);
procedure Put (To : out String;
Item : Num;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
end Fixed_Io;
-- Generic package for Input-Output of Enumeration Types
generic
type Enum is (<>);
package Enumeration_Io is
Default_Width : Field := 0;
Default_Setting : Type_Set := Upper_Case;
procedure Get (File : File_Type; Item : out Enum);
procedure Get (Item : out Enum);
procedure Put (File : File_Type;
Item : Enum;
Width : Field := Default_Width;
Set : Type_Set := Default_Setting);
procedure Put (Item : Enum;
Width : Field := Default_Width;
Set : Type_Set := Default_Setting);
procedure Get (From : String; Item : out Enum; Last : out Positive);
procedure Put (To : out String;
Item : Enum;
Set : Type_Set := Default_Setting);
end Enumeration_Io;
-- Exceptions
Status_Error : exception renames Io_Exceptions.Status_Error;
Mode_Error : exception renames Io_Exceptions.Mode_Error;
Name_Error : exception renames Io_Exceptions.Name_Error;
Use_Error : exception renames Io_Exceptions.Use_Error;
Device_Error : exception renames Io_Exceptions.Device_Error;
End_Error : exception renames Io_Exceptions.End_Error;
Data_Error : exception renames Io_Exceptions.Data_Error;
Layout_Error : exception renames Io_Exceptions.Layout_Error;
private
type File_Type is new Device_Independent_Io.File_Type;
end Text_Io;with Io_Exceptions;
package Window_Io is
pragma Subsystem (Object_Editor, Closed);
pragma Module_Name (4, 2219);
-- package for providing raw IO facilities to an image
type File_Type is private;
type File_Mode is (In_File, Out_File);
-- the mode of the handle. Each image can be opened twice - once
-- for input and once for output.
-- Create an image for IO.
-- Normally, a new empty image is created on this call.
-- If an image is already open for this job with the given name,
-- and the mode given /= the mode the image is open for, that
-- image will be opened for the new mode.
procedure Create (File : in out File_Type;
Mode : File_Mode := Out_File;
Name : String;
Form : String := "");
-- Open a previously closed image. The same rules apply for create
-- in the case one job opens the same image twice; once for input and
-- once for output
procedure Open (File : in out File_Type;
Mode : File_Mode := Out_File;
Name : String;
Form : String := "");
-- Terminate operations on this image.
procedure Close (File : in out File_Type);
-- Delete the image. Any other handles on this image are implicitly
-- closed.
procedure Delete (File : in out File_Type);
function Mode (File : File_Type) return File_Mode;
function Name (File : File_Type) return String;
function Form (File : File_Type) return String;
function Is_Open (File : File_Type) return Boolean;
package Raw is
-- gain access to the keyboard for "raw" input.
-- one channel may be opened per job.
-- no echoing or local editing is performed.
type Stream_Type is private;
procedure Open (Stream : in out Stream_Type);
procedure Close (Stream : in out Stream_Type;
Flush_Pending_Input : Boolean := False);
procedure Disconnect (Stream : in out Stream_Type);
-- free users keyboard
type Key is new Natural range 0 .. 1023;
type Key_String is array (Positive range <>) of Key;
-- a key is the basic bit of input.
subtype Simple_Key is Key range 0 .. 127;
-- a simple key represents the ascii characters
procedure Get (Stream : Stream_Type; Item : out Key);
procedure Get (Stream : Stream_Type; Item : out Key_String);
-- converting keys to characters
-- the ascii characters map directly to the first 128 keys
function Convert (C : Character) return Simple_Key;
function Convert (K : Simple_Key) return Character;
-- keys are mapped to logical names
-- these names correspond to the 'image attribute of the
-- enumerations in machine.editor_data.visible_key_names
subtype Terminal is String;
-- supported terminal types are Cit500R, Vt100, Rational
function Image (For_Key : Key; On_Terminal : Terminal) return String;
-- image is "", if For_Key is not defined for this terminal type
procedure Value (For_Key_Name : String;
On_Terminal : Terminal;
Result : out Key;
Found : out Boolean);
-- Found is false => For_Key_Name does not name a key on this terminal
function Value
(For_Key_Name : String; On_Terminal : Terminal) return Key;
Unknown_Key : exception;
-- raised by functional form of value
end Raw;
subtype Column_Number is Positive;
subtype Line_Number is Positive;
-- a file_type is initialized to column 1, line 1
subtype Count is Natural;
subtype Positive_Count is Count range 1 .. Count'Last;
-- output
-- characters are displayed at the current cursor position
-- control characters are displayed in reverse-video
type Designation is (Text, Prompt, Protected);
type Attribute is
record
Bold : Boolean;
Faint : Boolean;
Underscore : Boolean;
Inverse : Boolean;
Slow_Blink : Boolean;
Rapid_Blink : Boolean;
Unused_0 : Boolean;
Unused_1 : Boolean;
end record;
Vanilla : constant Attribute := (others => False);
type Character_Set is new Natural range 0 .. 15;
Plain : constant Character_Set := 0;
Graphics : constant Character_Set := 1;
type Font is
record
Kind : Character_Set;
Look : Attribute;
end record;
Normal : constant Font := Font'(Plain, Vanilla);
function Default_Font (For_Type : Designation) return Font;
-- the fonts normally used by the environment for these designations
-- are returned
procedure Position_Cursor (File : File_Type;
Line : Line_Number := Line_Number'First;
Column : Column_Number := Column_Number'First;
Offset : Natural := 0);
-- Position the cursor on the image.
-- Offset is used to position the cursor relative to the top of the window.
-- With an offset of 0, the cursor is made visible in the window using
-- the normal editor defaults.
-- With a positive offset, the image is scrolled in the window so the
-- cursor is the offset line in the window.
procedure Move_Cursor (File : File_Type;
Delta_Lines : Integer;
Delta_Columns : Integer;
Offset : Natural := 0);
procedure Report_Cursor (File : File_Type;
Line : out Line_Number;
Column : out Column_Number);
procedure Overwrite (File : File_Type;
Item : Character;
Image : Font := Normal;
Kind : Designation := Text);
-- writes ITEM at the current cursor position and advances column by 1
procedure Overwrite (File : File_Type;
Item : String;
Image : Font := Normal;
Kind : Designation := Text);
-- writes ITEM at the current cursor position and advances column by
-- ITEM'LENGTH
procedure Insert (File : File_Type;
Item : Character;
Image : Font := Normal;
Kind : Designation := Text);
-- writes ITEM at the current cursor position and advances column by 1
procedure Insert (File : File_Type;
Item : String;
Image : Font := Normal;
Kind : Designation := Text);
-- writes ITEM at the current cursor position and advances column by
-- ITEM'LENGTH
procedure New_Line (File : File_Type; Lines : Count := 1);
-- insert lines after the current line
-- advances line by Lines, and sets column to 1.
procedure Delete (File : File_Type; Characters : Count);
-- deletes Count characters at current position. Position is unchanged
procedure Delete_Lines (File : File_Type; Lines : Count := 1);
-- deletes Lines including the current line. Position is unchanged
-- input with editing
-- an input prompt with contents PROMPT will be displayed at the current
-- cursor position. Control of the keyboard will be returned to the
-- core editor for user input at the prompt.
procedure Get (File : File_Type;
Prompt : String := "[input]";
Item : out Character);
procedure Get (File : File_Type;
Prompt : String := "[input]";
Item : out String);
procedure Get_Line (File : File_Type;
Prompt : String := "[input]";
Item : out String;
Last : out Natural);
function Get_Line
(File : File_Type; Prompt : String := "[input]") return String;
-- banner operations
-- The value will be displayed in the banner for this image
-- fields are defined from left to right. The first few fields
-- are reserved for the editor. Users may specify field_names
-- of the form "FIELD_0" .. "FIELD_9". Currently 0 .. 2 are used
-- for job_number, start_time and blocked indication, but may be
-- reused by the user.
-- Calling set_banner with other values will be a noop.
procedure Set_Banner
(File : File_Type; Field_Name : String; Value : String);
function Read_Banner (File : File_Type; Field_Name : String) return String;
-- predefined field_names, may be passed to Set_Banner
function Job_Number return String;
function Job_Time return String;
-- sound the terminal bell
procedure Bell (File : File_Type);
-- information about the current image
function End_Of_Line (File : File_Type) return Boolean;
function End_Of_File (File : File_Type) return Boolean;
function Line_Length (File : File_Type) return Count;
function Line_Image (File : File_Type) return String;
function Char_At (File : File_Type) return Character;
function Font_At (File : File_Type) return Font;
function Last_Line (File : File_Type) return Line_Number;
-- information about the current window
-- the origin is the line and column number of the point of the image
-- located in the upper right corner of the window
procedure Report_Origin (File : File_Type;
Line : out Line_Number;
Column : out Column_Number);
-- the size of the window in characters
procedure Report_Size (File : File_Type;
Lines : out Positive_Count;
Columns : out Positive_Count);
-- the location of the window on the screen
-- the upper right corner of the screen is line 1, column 1
procedure Report_Location (File : File_Type;
Line : out Line_Number;
Column : out Column_Number);
end Window_Io;package Calendar is
pragma Subsystem (Kernel, Private_Part => Closed);
pragma Module_Name (4, 406);
type Time is private;
subtype Year_Number is Integer range 1901 .. 2099;
subtype Month_Number is Integer range 1 .. 12;
subtype Day_Number is Integer range 1 .. 31;
subtype Day_Duration is Duration range 0.0 .. 86_400.0;
function Clock return Time;
function Year (Date : Time) return Year_Number;
function Month (Date : Time) return Month_Number;
function Day (Date : Time) return Day_Number;
function Seconds (Date : Time) return Day_Duration;
procedure Split (Date : Time;
Year : out Year_Number;
Month : out Month_Number;
Day : out Day_Number;
Seconds : out Day_Duration);
function Time_Of (Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Seconds : Day_Duration := 0.0) return Time;
function "+" (Left : Time; Right : Duration) return Time;
function "+" (Left : Duration; Right : Time) return Time;
function "-" (Left : Time; Right : Duration) return Time;
function "-" (Left : Time; Right : Time) return Duration;
function "<" (Left, Right : Time) return Boolean;
function "<=" (Left, Right : Time) return Boolean;
function ">" (Left, Right : Time) return Boolean;
function ">=" (Left, Right : Time) return Boolean;
Time_Error : exception; -- can be raised by TIME_OF, "+" and "-"
end Calendar;package System is
pragma Read_Only;
pragma Open_Private_Part;
pragma Subsystem (Ada_Base);
pragma Module_Name (4, 66);
type Address is private;
Null_Address : constant Address;
type Name is (R1000);
System_Name : constant Name := R1000;
Bit : constant := 1;
Storage_Unit : constant := 1 * Bit;
Word_Size : constant := 128 * Bit;
Byte_Size : constant := 8 * Bit;
Megabyte : constant := (2 ** 20) * Byte_Size;
Memory_Size : constant := 32 * Megabyte;
-- System-Dependent Named Numbers
Min_Int : constant := Long_Integer'Pos (Long_Integer'First);
Max_Int : constant := Long_Integer'Pos (Long_Integer'Last);
Max_Digits : constant := 15;
Max_Mantissa : constant := 63;
Fine_Delta : constant := 1.0 / (2.0 ** 63);
Tick : constant := 200.0E-9;
subtype Priority is Integer range 0 .. 5;
type Byte is new Natural range 0 .. 255;
type Byte_String is array (Natural range <>) of Byte;
-- Basic units of transmission/reception to/from IO devices.
type Virtual_Processor_Number is new Long_Integer range 0 .. 2 ** 10 - 1;
type Module_Number is new Long_Integer range 0 .. 2 ** 22 - 1;
type Module_Name is new Long_Integer range 0 .. 2 ** 32 - 1;
subtype Code_Segment_Name is Module_Name range 0 .. 2 ** 24 - 1;
type Bit_Offset is new Long_Integer range 0 .. 2 ** 32 - 1;
Null_Module : constant Module_Name := 0;
function Convert (The_Address : Address) return Long_Integer;
pragma Suppress (Elaboration_Check, Convert);
function Extract_Vp (From_Address : Address)
return Virtual_Processor_Number;
pragma Suppress (Elaboration_Check, Extract_Vp);
function Extract_Number (From_Address : Address) return Module_Number;
pragma Suppress (Elaboration_Check, Extract_Number);
function Extract_Name (From_Address : Address) return Module_Name;
pragma Suppress (Elaboration_Check, Extract_Name);
function Extract_Offset (From_Address : Address) return Bit_Offset;
pragma Suppress (Elaboration_Check, Extract_Offset);
function Get_Vp (From_Name : Module_Name) return Virtual_Processor_Number;
pragma Suppress (Elaboration_Check, Get_Vp);
function Get_Number (From_Name : Module_Name) return Module_Number;
pragma Suppress (Elaboration_Check, Get_Number);
function Compose_Name (With_Vp : Virtual_Processor_Number;
With_Number : Module_Number) return Module_Name;
pragma Suppress (Elaboration_Check, Compose_Name);
function Current_Name return Module_Name;
pragma Suppress (Elaboration_Check, Current_Name);
function Current_Vp return Virtual_Processor_Number;
pragma Suppress (Elaboration_Check, Current_Vp);
function Current_Number return Module_Number;
pragma Suppress (Elaboration_Check, Current_Number);
type Segment is private;
Null_Segment : constant Segment;
type Package_Type is private;
pragma Enable_Runtime_Privacy (Package_Type);
Null_Package : constant Package_Type;
Invalid_Package_Value : exception;
type Exception_Number is new Long_Integer range 0 .. 2 ** 48 - 1;
Operand_Class_Error : exception;
pragma Exception_Name (Operand_Class_Error, 96);
Type_Error : exception;
pragma Exception_Name (Type_Error, 97);
Visibility_Error : exception;
pragma Exception_Name (Visibility_Error, 98);
Capability_Error : exception;
pragma Exception_Name (Capability_Error, 99);
Machine_Restriction : exception;
pragma Exception_Name (Machine_Restriction, 100);
Illegal_Instruction : exception;
pragma Exception_Name (Illegal_Instruction, 101);
Illegal_Reference : exception;
pragma Exception_Name (Illegal_Reference, 102);
Illegal_Frame_Exit : exception;
pragma Exception_Name (Illegal_Frame_Exit, 103);
Record_Field_Error : exception;
pragma Exception_Name (Record_Field_Error, 104);
Utility_Error : exception;
pragma Exception_Name (Utility_Error, 105);
Unsupported_Feature : exception;
pragma Exception_Name (Unsupported_Feature, 106);
Illegal_Heap_Access : exception;
pragma Exception_Name (Illegal_Heap_Access, 107);
Select_Use_Error : exception;
pragma Exception_Name (Select_Use_Error, 108);
Frame_Establish_Error : exception;
pragma Exception_Name (Frame_Establish_Error, 129);
Nonexistent_Space_Error : exception;
pragma Exception_Name (Nonexistent_Space_Error, 131);
Nonexistent_Page_Error : exception;
pragma Exception_Name (Nonexistent_Page_Error, 132);
Write_To_Read_Only_Page : exception;
pragma Exception_Name (Write_To_Read_Only_Page, 133);
Heap_Pointer_Copy_Error : exception;
pragma Exception_Name (Heap_Pointer_Copy_Error, 134);
Assertion_Error : exception;
pragma Exception_Name (Assertion_Error, 135);
Microcode_Assist_Error : exception;
pragma Exception_Name (Microcode_Assist_Error, 136);
private
type Address is new Long_Integer;
Null_Address : constant Address := 0;
type Segment is access Boolean;
pragma Segmented_Heap (Segment);
Null_Segment : constant Segment := null;
type Package_Type is new Long_Integer;
Null_Package : constant Package_Type := 0;
end System; package System is
pragma Read_Only;
pragma Open_Private_Part;
pragma Subsystem (Ada_Base);
pragma Module_Name (4, 66);
type Address is private;
Null_Address : constant Address;
type Name is (R1000);
System_Name : constant Name := R1000;
Bit : constant := 1;
Storage_Unit : constant := 1 * Bit;
Word_Size : constant := 128 * Bit;
Byte_Size : constant := 8 * Bit;
Megabyte : constant := (2 ** 20) * Byte_Size;
Memory_Size : constant := 32 * Megabyte;
-- System-Dependent Named Numbers
Min_Int : constant := Long_Integer'Pos (Long_Integer'First);
Max_Int : constant := Long_Integer'Pos (Long_Integer'Last);
Max_Digits : constant := 15;
Max_Mantissa : constant := 63;
Fine_Delta : constant := 1.0 / (2.0 ** 63);
Tick : constant := 200.0E-9;
subtype Priority is Integer range 0 .. 5;
type Byte is new Natural range 0 .. 255;
type Byte_String is array (Natural range <>) of Byte;
-- Basic units of transmission/reception to/from IO devices.
type Virtual_Processor_Number is new Long_Integer range 0 .. 2 ** 10 - 1;
type Module_Number is new Long_Integer range 0 .. 2 ** 22 - 1;
type Module_Name is new Long_Integer range 0 .. 2 ** 32 - 1;
subtype Code_Segment_Name is Module_Name range 0 .. 2 ** 24 - 1;
type Bit_Offset is new Long_Integer range 0 .. 2 ** 32 - 1;
Null_Module : constant Module_Name := 0;
function Convert (The_Address : Address) return Long_Integer;
pragma Suppress (Elaboration_Check, Convert);
function Extract_Vp (From_Address : Address)
return Virtual_Processor_Number;
pragma Suppress (Elaboration_Check, Extract_Vp);
function Extract_Number (From_Address : Address) return Module_Number;
pragma Suppress (Elaboration_Check, Extract_Number);
function Extract_Name (From_Address : Address) return Module_Name;
pragma Suppress (Elaboration_Check, Extract_Name);
function Extract_Offset (From_Address : Address) return Bit_Offset;
pragma Suppress (Elaboration_Check, Extract_Offset);
function Get_Vp (From_Name : Module_Name) return Virtual_Processor_Number;
pragma Suppress (Elaboration_Check, Get_Vp);
function Get_Number (From_Name : Module_Name) return Module_Number;
pragma Suppress (Elaboration_Check, Get_Number);
function Compose_Name (With_Vp : Virtual_Processor_Number;
With_Number : Module_Number) return Module_Name;
pragma Suppress (Elaboration_Check, Compose_Name);
function Current_Name return Module_Name;
pragma Suppress (Elaboration_Check, Current_Name);
function Current_Vp return Virtual_Processor_Number;
pragma Suppress (Elaboration_Check, Current_Vp);
function Current_Number return Module_Number;
pragma Suppress (Elaboration_Check, Current_Number);
type Segment is private;
Null_Segment : constant Segment;
type Package_Type is private;
pragma Enable_Runtime_Privacy (Package_Type);
Null_Package : constant Package_Type;
Invalid_Package_Value : exception;
type Exception_Number is new Long_Integer range 0 .. 2 ** 48 - 1;
Operand_Class_Error : exception;
pragma Exception_Name (Operand_Class_Error, 96);
Type_Error : exception;
pragma Exception_Name (Type_Error, 97);
Visibility_Error : exception;
pragma Exception_Name (Visibility_Error, 98);
Capability_Error : exception;
pragma Exception_Name (Capability_Error, 99);
Machine_Restriction : exception;
pragma Exception_Name (Machine_Restriction, 100);
Illegal_Instruction : exception;
pragma Exception_Name (Illegal_Instruction, 101);
Illegal_Reference : exception;
pragma Exception_Name (Illegal_Reference, 102);
Illegal_Frame_Exit : exception;
pragma Exception_Name (Illegal_Frame_Exit, 103);
Record_Field_Error : exception;
pragma Exception_Name (Record_Field_Error, 104);
Utility_Error : exception;
pragma Exception_Name (Utility_Error, 105);
Unsupported_Feature : exception;
pragma Exception_Name (Unsupported_Feature, 106);
Illegal_Heap_Access : exception;
pragma Exception_Name (Illegal_Heap_Access, 107);
Select_Use_Error : exception;
pragma Exception_Name (Select_Use_Error, 108);
Frame_Establish_Error : exception;
pragma Exception_Name (Frame_Establish_Error, 129);
Nonexistent_Space_Error : exception;
pragma Exception_Name (Nonexistent_Space_Error, 131);
Nonexistent_Page_Error : exception;
pragma Exception_Name (Nonexistent_Page_Error, 132);
Write_To_Read_Only_Page : exception;
pragma Exception_Name (Write_To_Read_Only_Page, 133);
Heap_Pointer_Copy_Error : exception;
pragma Exception_Name (Heap_Pointer_Copy_Error, 134);
Assertion_Error : exception;
pragma Exception_Name (Assertion_Error, 135);
Microcode_Assist_Error : exception;
pragma Exception_Name (Microcode_Assist_Error, 136);
private
type Address is new Long_Integer;
Null_Address : constant Address := 0;
type Segment is access Boolean;
pragma Segmented_Heap (Segment);
Null_Segment : constant Segment := null;
type Package_Type is new Long_Integer;
Null_Package : constant Package_Type := 0;
end System; generic
type Source is limited private;
type Target is limited private;
function Unchecked_Conversion (S : Source) return Target;
pragma Subsystem (Miscellaneous);
pragma Module_Name (4, 824);generic
type Object is limited private;
type Name is access Object;
procedure Unchecked_Deallocation (X : in out Name);
pragma Subsystem (Miscellaneous);
pragma Module_Name (4, 825);procedure Enable_Product_Keymaps
(Keymap : String := "!Machine.Editor_Data.@_Commands'Body";
Overrides : String := "Foo=>FALSE,Bar=>TRUE";
Response : String := "<PROFILE>");
pragma Loaded_Main;procedure Facit_Commands;
----This file generated on: December 13, 1989 at 8:50:09 AM
----From Rational Development source file: !ENVIRONMENT.EDITOR_KEYS.REV10_WORKING.UNITS.CREATE_COMMANDS_FILES.MASTER_KEYS_FILE'V(48)
----By user: GEB
----For terminal type: FACITwith Access_List;
with Ada;
with Cmvc;
with Command;
with Common;
with Compilation;
--/ if DOCUMENT_FORMATTER then
--// with COMPOSE;
--/ end if;
with Debug;
--/ if DESIGN_FACILITY then
--// with DESIGN_IMPLEMENTATION;
--/ end if;
with Editor;
with Io;
with Job;
with Library;
--/ if MAIL then
--// with MAIL;
--/ end if;
with Operator;
with Queue;
with Script;
--/ if SPELLER then
--// with SPELLER;
--/ end if;
with System_Utilities;
with Text;
with What;
with Facit_Key_Names;
----This file generated on: December 13, 1989 at 8:50:09 AM
----From Rational Development source file !ENVIRONMENT.EDITOR_KEYS.REV10_WORKING.UNITS.CREATE_COMMANDS_FILES.MASTER_KEYS_FILE'V(48)
----By user: GEB
----For terminal type: FACIT
procedure Facit_Commands is
use Facit_Key_Names;
type Intent is (Interrupt, Prompt, Execute);
Action : Intent;
Key1, Key2, Key3, Key4, Key5, Key6 : Key_Names;
begin
case Action is
when Interrupt =>
case Key1 is
when C_G =>
Job.Interrupt;
when Esc_G | Esc_S_G =>
Job.Kill (0);
when C_F1 =>
Debug.Stop (Name => "");
when C_F11 =>
Job.Kill (0);
when Esc_C_F11 =>
Job.Disable (0);
when others =>
null;
end case;
when Prompt =>
case Key1 is
when Object =>
case Key2 is
when 'L' | 'l' =>
Common.Revert;
when others =>
null;
end case;
when Image =>
case Key2 is
when '+' | '=' =>
Editor.Image.Find (Name => "name or name fragment");
when '/' | '?' =>
Editor.Image.Find (Name => "");
when others =>
null;
end case;
when S_F5 =>
What.Does (Name => "");
when Esc_F8 =>
Library.Create_Directory;
when C_F8 =>
Text.Create;
when Esc_C_F3 =>
Debug.Modify (New_Value => "",
Variable => "<SELECTION>",
Stack_Frame => 0);
when Esc_C_F8 =>
Library.Create_World;
when others =>
null;
end case;
when Execute =>
case Key1 is
when Nul =>
Editor.Mark.Push;
when C_A =>
Editor.Line.Beginning_Of;
when C_B | Back_Tab | Esc_C_B =>
Editor.Line.Beginning_Of;
when C_C =>
Editor.Hold_Stack.Push;
when C_D =>
Editor.Char.Delete_Forward;
when C_E =>
Editor.Line.End_Of;
when C_F =>
Editor.Search.Next (Target => "", Wildcard => False);
when Backspace =>
Editor.Cursor.Left;
when Tab =>
Editor.Line.End_Of;
when C_J =>
Editor.Cursor.Right;
when C_K =>
Editor.Line.Delete_Forward;
when C_L =>
Editor.Screen.Redraw;
when C_M =>
Editor.Line.Indent;
when C_N =>
Editor.Cursor.Down;
when C_O =>
Editor.Line.Open;
when C_Q =>
Editor.Char.Quote;
when C_R =>
Editor.Search.Previous (Target => "", Wildcard => False);
when C_S =>
Editor.Search.Next (Target => "", Wildcard => False);
when C_T =>
Editor.Char.Transpose;
when C_U =>
Editor.Cursor.Up;
when C_V =>
Editor.Image.Down;
when C_W =>
Editor.Region.Delete;
when C_X =>
Editor.Set.Designation_Off;
when C_Y =>
Editor.Hold_Stack.Top;
when C_Z =>
Editor.Image.Up;
when ' ' =>
Editor.Char.Insert_Character (1, ' ');
when Delete =>
Editor.Char.Delete_Backward;
when Object =>
case Key2 is
when Tab | 'E' | 'e' =>
Common.Object.Last_Child;
when '!' | '1' =>
Common.Expand;
when '+' | '=' =>
Common.Explain;
when '.' | '>' =>
Common.Elide;
when '/' | '?' =>
Common.Explain;
when 'A' | 'a' | Back_Tab =>
Common.Object.First_Child;
when 'B' | 'b' =>
Common.Object.First_Child;
when 'C' | 'c' =>
Common.Object.Copy;
when 'D' | 'K' | 'd' | 'k' =>
Common.Object.Delete;
when 'G' | 'g' =>
Common.Abandon;
when 'H' | 'h' =>
Common.Object.Parent;
when 'I' | 'i' =>
Common.Object.Insert;
when 'J' | 'j' =>
Common.Object.Child;
when 'M' | 'm' =>
Common.Object.Move;
when 'N' | 'n' =>
Common.Object.Next;
when 'R' | 'r' =>
Common.Redo;
when 'S' | 's' =>
Common.Sort_Image;
when 'U' | 'u' =>
Common.Undo;
when 'V' | 'v' =>
Common.Redo;
when 'X' | 'x' =>
Common.Release;
when Promot | Enter =>
Common.Commit;
when Up =>
Common.Object.Previous;
when Down =>
Common.Object.Next;
when Left =>
Common.Object.Parent;
when Right =>
Common.Object.Child;
when F4 =>
Common.Definition (Name => "<CURSOR>",
In_Place => False,
Visible => False);
when others =>
null;
end case;
when Region =>
case Key2 is
when Tab | 'E' | 'e' =>
Editor.Region.End_Of;
when '"' | ''' | '6' | '^' =>
Editor.Region.Capitalize;
when '(' | '9' | '[' | '{' =>
Editor.Region.Start;
when ')' | '0' | ']' | '}' =>
Editor.Region.Finish;
when '+' | '=' =>
Editor.Region.Uncomment;
when ',' | '<' =>
Editor.Region.Lower_Case;
when '-' | '_' =>
Editor.Region.Comment;
when '.' | '>' =>
Editor.Region.Upper_Case;
when 'A' | 'a' | Back_Tab =>
Editor.Region.Beginning_Of;
when 'B' | 'b' =>
Editor.Region.Beginning_Of;
when 'C' | 'c' =>
Editor.Region.Copy;
when 'D' | 'K' | 'd' | 'k' =>
Editor.Region.Delete;
when 'F' | 'f' =>
Editor.Region.Fill;
when 'H' | 'h' =>
Editor.Hold_Stack.Previous;
when 'J' | 'j' =>
Editor.Hold_Stack.Next;
when 'M' | 'm' =>
Editor.Region.Move;
when 'N' | 'n' =>
Editor.Hold_Stack.Push;
when 'P' | 'p' =>
Editor.Hold_Stack.Copy_Top;
when 'Q' | 'q' | Complt =>
Editor.Region.Justify;
when 'R' | 'r' =>
Editor.Hold_Stack.Rotate;
when 'T' | 't' =>
Editor.Hold_Stack.Swap;
when 'U' | 'u' =>
Editor.Hold_Stack.Top;
when 'X' | 'x' =>
Editor.Region.Off;
when '`' | '~' =>
Editor.Region.Capitalize;
when Delete =>
Editor.Hold_Stack.Delete_Top;
when Format =>
Editor.Region.Fill;
when Up =>
Editor.Hold_Stack.Top;
when Down =>
Editor.Hold_Stack.Push;
when Left =>
Editor.Hold_Stack.Previous;
when Right =>
Editor.Hold_Stack.Next;
when others =>
null;
end case;
when Window =>
case Key2 is
when Tab | 'E' | 'e' =>
Editor.Window.End_Of;
when '!' | '1' =>
Editor.Window.Expand;
when '#' | '3' =>
Editor.Window.Frames (3);
when '$' | '4' =>
Editor.Window.Frames (4);
when '%' | '5' =>
Editor.Window.Frames (5);
when '&' | '7' =>
Editor.Window.Frames (7);
when '+' | '=' | F4 =>
Editor.Window.Directory;
when '.' | '>' =>
Editor.Window.Expand (-4);
when '/' | '?' =>
Editor.Window.Directory;
when '2' | '@' =>
Editor.Window.Frames (2);
when '6' | '^' =>
Editor.Window.Frames (6);
when 'A' | 'a' | Back_Tab =>
Editor.Window.Beginning_Of;
when 'B' | 'b' =>
Editor.Window.Beginning_Of;
when 'C' | 'c' =>
Editor.Window.Copy;
when 'D' | 'K' | 'W' | 'X' | 'd' | 'k' | 'w' | 'x' =>
Editor.Window.Delete;
when 'F' | 'f' =>
Editor.Window.Focus;
when 'H' | 'h' =>
Common.Enclosing (In_Place => False,
Library => False);
when 'J' | 'j' =>
Editor.Window.Join (1);
when 'M' | 'Z' | 'm' | 'z' | Promot | Enter =>
Editor.Window.Promote;
when 'N' | 'n' =>
Editor.Window.Next;
when 'O' | 'o' =>
Editor.Window.Join (1);
when 'T' | 't' =>
Editor.Window.Transpose;
when 'U' | 'u' =>
Editor.Window.Previous;
when 'V' | 'v' =>
Editor.Window.Child;
when 'Y' | 'y' =>
Editor.Window.Demote;
when Delete =>
Editor.Window.Join (-1);
when Format =>
Editor.Window.Focus;
when Up =>
Editor.Window.Previous;
when Down =>
Editor.Window.Next;
when Left =>
Editor.Window.Parent;
when Right =>
Editor.Window.Child;
when F7 | S_F7 =>
Editor.Window.Demote;
when others =>
null;
end case;
when Promot =>
Common.Promote;
when Complt =>
Common.Complete;
when Format =>
Common.Format;
when Up =>
Editor.Cursor.Up;
when Down =>
Editor.Cursor.Down;
when Left =>
Editor.Cursor.Left;
when Right =>
Editor.Cursor.Right;
when Image =>
case Key2 is
when Tab | 'E' | 'e' =>
Editor.Image.End_Of;
when '!' | '1' =>
Debug.Source ("_1");
when '#' | '3' =>
Debug.Source ("_3");
when '$' | '4' =>
Debug.Source ("_4");
when '%' | '5' =>
Debug.Source ("_5");
when '&' | '7' =>
Debug.Source ("_7");
when '(' | '9' =>
Debug.Source ("_9");
when ')' | '0' =>
Debug.Source ("_10");
when '*' | '8' =>
Debug.Source ("_8");
when '2' | '@' =>
Debug.Source ("_2");
when '6' | '^' =>
Debug.Source ("_6");
when 'A' | 'a' | Back_Tab =>
Editor.Image.Beginning_Of;
when 'B' | 'b' =>
Editor.Image.Beginning_Of;
when 'F' | 'f' =>
Editor.Set.Fill_Mode (True);
when 'H' | 'h' =>
Editor.Image.Left;
when 'I' | 'i' =>
Editor.Set.Insert_Mode (True);
when 'J' | 'j' =>
Editor.Image.Right;
when 'N' | 'n' =>
Editor.Image.Down;
when 'O' | 'o' =>
Editor.Set.Insert_Mode (False);
when 'U' | 'u' =>
Editor.Image.Up;
when 'X' | 'x' =>
Editor.Set.Fill_Mode (False);
when Up =>
Editor.Image.Up;
when Down =>
Editor.Image.Down;
when Left =>
Editor.Image.Left;
when Right =>
Editor.Image.Right;
when others =>
null;
end case;
when Line =>
case Key2 is
when Tab | 'E' | 'e' =>
Editor.Line.End_Of;
when '$' | '4' =>
Editor.Line.Center;
when '+' | '=' =>
What.Line;
when ',' | '<' =>
Editor.Line.Lower_Case;
when '.' | '>' =>
Editor.Line.Upper_Case;
when '/' | '?' =>
What.Line;
when '6' | '^' =>
Editor.Line.Capitalize;
when 'A' | 'a' | Back_Tab =>
Editor.Line.Beginning_Of;
when 'B' | 'b' =>
Editor.Line.Beginning_Of;
when 'C' | 'c' =>
Editor.Line.Copy;
when 'D' | 'd' =>
Editor.Line.Delete;
when 'I' | 'i' =>
Editor.Line.Insert (1);
when 'J' | 'j' =>
Editor.Line.Join;
when 'K' | 'k' =>
Editor.Line.Delete_Forward;
when 'O' | 'o' =>
Editor.Line.Open;
when 'T' | 't' =>
Editor.Line.Transpose;
when '`' | '~' =>
Editor.Line.Capitalize;
when Delete =>
Editor.Line.Delete_Backward;
when Up =>
Editor.Cursor.Up;
when Down =>
Editor.Cursor.Down;
when others =>
null;
end case;
when Word =>
case Key2 is
when Tab | 'E' | 'e' =>
Editor.Word.End_Of;
--/ if SPELLER then
--// when C_W | 'w' =>
--// SPELLER.SPELLER_WINDOW (IN_PLACE => FALSE);
--/ end if;
when ',' | '<' =>
Editor.Word.Lower_Case;
when '.' | '>' =>
Editor.Word.Upper_Case;
--/ if SPELLER then
--// when '/' | '?' =>
--// SPELLER.CHECK_TEXT (DATA => "<TEXT>");
--/ end if;
when '6' | '^' =>
Editor.Word.Capitalize;
when 'A' | 'a' | Back_Tab =>
Editor.Word.Beginning_Of;
when 'B' | 'b' =>
Editor.Word.Beginning_Of;
when 'D' | 'd' =>
Editor.Word.Delete;
--/ if SPELLER then
--// when 'I' | 'i' | PROMOT =>
--// SPELLER.LEARN_WORD (THE_WORD => "",DICTIONARY => 0);
--/ end if;
when 'K' | 'k' =>
Editor.Word.Delete_Forward;
--/ if SPELLER then
--// when 'L' | 'l' =>
--// SPELLER.LEARN_WORD (THE_WORD => "",DICTIONARY => 1);
--// when 'M' | 'm' =>
--// SPELLER.CHECK_IMAGE;
--// when 'N' | 'n' =>
--// SPELLER.EXPLAIN_NEXT;
--// when 'R' | 'r' =>
--// SPELLER.LEARN_REPLACEMENT (THE_WORD => "",CHOICE => 1,DICTIONARY => 0);
--/ end if;
when 'T' | 't' =>
Editor.Word.Transpose;
--/ if SPELLER then
--// when 'W' =>
--// SPELLER.SPELLER_WINDOW (IN_PLACE => TRUE);
--// when 'X' | 'x' | COMPLT =>
--// SPELLER.EXCHANGE_WORD (CHOICE => 1);
--/ end if;
when '`' | '~' =>
Editor.Word.Capitalize;
when Delete =>
Editor.Word.Delete_Backward;
--/ if SPELLER then
--// when DOWN =>
--// SPELLER.EXPLAIN_NEXT;
--/ end if;
when Left =>
Editor.Word.Previous;
when Right =>
Editor.Word.Next;
--/ if SPELLER then
--// when NUMERIC_1 =>
--// SPELLER.EXCHANGE_WORD (CHOICE => 1);
--// when NUMERIC_2 =>
--// SPELLER.EXCHANGE_WORD (CHOICE => 2);
--// when NUMERIC_3 =>
--// SPELLER.EXCHANGE_WORD (CHOICE => 3);
--// when NUMERIC_4 =>
--// SPELLER.EXCHANGE_WORD (CHOICE => 4);
--// when NUMERIC_5 =>
--// SPELLER.EXCHANGE_WORD (CHOICE => 5);
--// when NUMERIC_6 =>
--// SPELLER.EXCHANGE_WORD (CHOICE => 6);
--// when NUMERIC_7 =>
--// SPELLER.EXCHANGE_WORD (CHOICE => 7);
--// when NUMERIC_8 =>
--// SPELLER.EXCHANGE_WORD (CHOICE => 8);
--// when NUMERIC_9 =>
--// SPELLER.EXCHANGE_WORD (CHOICE => 9);
--// when NUMERIC_0 =>
--// SPELLER.EXCHANGE_WORD (CHOICE => 10);
--/ end if;
when others =>
null;
end case;
when Mark =>
case Key2 is
when Tab | ')' | '0' | 'E' | ']' | 'e' | '}' =>
Editor.Macro.Finish;
when '(' | '9' | 'A' | '[' | 'a' | '{' | Back_Tab =>
Editor.Macro.Start;
when 'B' | 'b' =>
Editor.Macro.Start;
when 'F' | 'f' =>
Editor.Macro.Bind;
when 'H' | 'h' =>
Editor.Mark.Previous;
when 'J' | 'j' =>
Editor.Mark.Next;
when 'M' | 'X' | 'm' | 'x' | Promot | Enter =>
Editor.Macro.Execute;
when 'N' | 'n' =>
Editor.Mark.Push;
when 'P' | 'p' =>
Editor.Mark.Copy_Top;
when 'R' | 'r' =>
Editor.Mark.Rotate;
when 'T' | 't' =>
Editor.Mark.Swap;
when 'U' | 'u' =>
Editor.Mark.Top;
when Delete =>
Editor.Mark.Delete_Top;
when Up =>
Editor.Mark.Top;
when Down =>
Editor.Mark.Push;
when Left =>
Editor.Mark.Previous;
when Right =>
Editor.Mark.Next;
when F4 =>
Editor.Macro.Bind;
when others =>
null;
end case;
when F1 =>
Debug.Run;
when F2 =>
Debug.Source (Location => "", Stack_Frame => 0);
when F3 =>
Debug.Put;
when F4 =>
Common.Definition
(Name => "<CURSOR>", In_Place => False, Visible => True);
when F5 =>
What.Does (Name => "Help_On_Help");
when F6 =>
Ada.Install_Unit;
when F7 =>
Common.Edit;
when F8 =>
Common.Create_Command;
when F9 =>
Ada.Other_Part (Name => "<IMAGE>", In_Place => False);
when F10 =>
Common.Semanticize;
when F11 =>
Queue.Print;
when F12 =>
What.Time;
when Numeric_1 =>
Editor.Set.Argument_Digit (1);
when Numeric_2 =>
Editor.Set.Argument_Digit (2);
when Numeric_3 =>
Editor.Set.Argument_Digit (3);
when Numeric_4 =>
Editor.Set.Argument_Digit (4);
when Numeric_5 =>
Editor.Set.Argument_Digit (5);
when Numeric_6 =>
Editor.Set.Argument_Digit (6);
when Numeric_7 =>
Editor.Set.Argument_Digit (7);
when Numeric_8 =>
Editor.Set.Argument_Digit (8);
when Numeric_9 =>
Editor.Set.Argument_Digit (9);
when Numeric_0 =>
Editor.Set.Argument_Digit (0);
when Dash =>
Editor.Set.Argument_Minus;
when Dot =>
Text.End_Of_Input;
when Enter =>
Common.Commit;
when Numeric_Comma =>
Editor.Set.Argument_Prefix;
when S_Up =>
Editor.Window.Previous;
when S_Down =>
Editor.Window.Next;
when S_F1 =>
Debug.Execute;
when S_F2 =>
Debug.Break (Location => "<SELECTION>",
Stack_Frame => 0,
Count => 1,
In_Task => "",
Default_Lifetime => True);
when S_F3 =>
Debug.Catch (Name => "<SELECTION>",
In_Task => "",
At_Location => "");
when S_F4 =>
Common.Definition
(Name => "<CURSOR>", In_Place => True, Visible => False);
when S_F6 =>
Ada.Code_Unit;
when S_F7 =>
Common.Demote;
when S_F8 =>
Ada.Create_Body;
when S_F9 =>
Ada.Other_Part (Name => "<IMAGE>", In_Place => True);
when S_F10 =>
Ada.Get_Errors;
when S_F11 =>
Job.Enable (0);
when S_F12 =>
What.Load;
when Esc_C_A =>
Editor.Line.Beginning_Of;
when Esc_C_C =>
Editor.Line.Copy;
when Esc_C_D =>
Editor.Line.Delete;
when Esc_C_E =>
Editor.Line.End_Of;
when Esc_C_F =>
Editor.Line.Delete_Backward;
when Esc_Backspace =>
Editor.Cursor.Left (8);
when Esc_Tab =>
Editor.Char.Tab_Forward;
when Esc_C_J =>
Editor.Cursor.Right (8);
when Esc_C_K =>
Editor.Line.Delete_Forward;
when Esc_C_M =>
Command.Spawn;
when Esc_C_N =>
Editor.Cursor.Down (8);
when Esc_C_O | Esc_O =>
Editor.Line.Join;
when Esc_C_T =>
Editor.Line.Transpose;
when Esc_C_U =>
Editor.Cursor.Up (8);
when Esc_Quotation | C_F5 =>
Editor.Key.Name;
--/ if DOCUMENT_FORMATTER then
--// when ESC_PERCENT | ESC_5 =>
--// COMPOSE (DOCUMENT => "<CURSOR>",DEVICE => "PostScript",OPTIONS => "",RESPONSE => "<PROFILE>");
--/ end if;
when Esc_Tick =>
Editor.Char.Quote;
when Esc_Left_Paren | Esc_9 =>
Editor.Char.Insert_String ("(""");
when Esc_Right_Paren | Esc_0 =>
Editor.Char.Insert_String (""")");
when Esc_Star | Esc_8 =>
Editor.Char.Quote;
when Esc_Plus | Esc_Slash | Esc_Query =>
Common.Explain;
when Esc_Comma | Esc_Less_Than =>
Editor.Word.Lower_Case;
when Esc_Period | Esc_Greater_Than =>
Editor.Word.Upper_Case;
when Esc_2 | Esc_At_Sign =>
case Key2 is
--/ if DESIGN_FACILITY then
--// when 'C' | 'c' =>
--// EDITOR.CHAR.INSERT_STRING("--| @COMPONENT_KIND ");
--/ end if;
when 'D' | 'd' =>
case Key3 is
--/ if DESIGN_FACILITY then
--// when 'E' | 'e' =>
--// EDITOR.CHAR.INSERT_STRING("--| @DECOMPOSITION ");
--// when 'S' | 's' =>
--// EDITOR.CHAR.INSERT_STRING("--| @DATA_STRUCTURE ");
--/ end if;
when others =>
null;
end case;
--/ if DESIGN_FACILITY then
--// when 'F' | 'f' =>
--// EDITOR.CHAR.INSERT_STRING("--| @FILE_STRUCTURE ");
--// when 'I' | 'i' =>
--// EDITOR.CHAR.INSERT_STRING("--| @INPUT ");
--// when 'N' | 'n' =>
--// EDITOR.CHAR.INSERT_STRING("--| @NOTE ");
--// when 'O' | 'o' =>
--// EDITOR.CHAR.INSERT_STRING("--| @OUTPUT ");
--/ end if;
when 'R' | 'r' =>
case Key3 is
--/ if DESIGN_FACILITY then
--// when 'A' | 'a' =>
--// EDITOR.CHAR.INSERT_STRING("--| @RAISES ");
--/ end if;
when 'C' | 'c' =>
case Key4 is
--/ if DESIGN_FACILITY then
--// when 'A' | 'a' =>
--// EDITOR.CHAR.INSERT_STRING("--| @REQUIREMENT CAPABILITY ");
--// when 'O' | 'o' =>
--// EDITOR.CHAR.INSERT_STRING("--| @REQUIREMENT CONSTITUENT ");
--/ end if;
when others =>
null;
end case;
--/ if DESIGN_FACILITY then
--// when 'F' | 'f' =>
--// EDITOR.CHAR.INSERT_STRING("--| @REQUIREMENT FUNCTION ");
--// when 'I' | 'i' =>
--// EDITOR.CHAR.INSERT_STRING("--| @REQUIREMENT INTERFACE ");
--// when 'S' | 's' =>
--// EDITOR.CHAR.INSERT_STRING("--| @REQUIREMENT SUBFUNCTION ");
--/ end if;
when others =>
null;
end case;
when 'S' | 's' =>
case Key3 is
--/ if DESIGN_FACILITY then
--// when 'A' | 'a' =>
--// EDITOR.CHAR.INSERT_STRING("--| @SATISFIES ");
--// when 'T' | 't' =>
--// EDITOR.CHAR.INSERT_STRING("--| @STATES ");
--/ end if;
when others =>
null;
end case;
--/ if DESIGN_FACILITY then
--// when ESC_2 | ESC_AT_SIGN =>
--// EDITOR.CHAR.INSERT_STRING("--| @");
--/ end if;
when others =>
null;
end case;
when Esc_3 =>
Cmvc.Check_In (What_Object => "<CURSOR>",
Comments => "",
Work_Order => "<DEFAULT>",
Response => "<PROFILE>");
when Esc_4 =>
Cmvc.Check_Out (What_Object => "<CURSOR>",
Comments => "",
Allow_Demotion => False,
Allow_Implicit_Accept_Changes => True,
Expected_Check_In_Time => "<TOMORROW>",
Work_Order => "<DEFAULT>",
Response => "<PROFILE>");
when Esc_6 | Esc_Circumflex =>
Editor.Word.Capitalize;
when Esc_Semicolon =>
Editor.Char.Insert_String (":=");
when Esc_Equal =>
Editor.Char.Insert_String ("=>");
when Esc_A | Esc_S_A =>
Editor.Word.Beginning_Of;
when Esc_B | Esc_S_B =>
Editor.Word.Beginning_Of;
when Esc_C | Esc_Y | Esc_S_C | Esc_S_Y =>
Editor.Hold_Stack.Next;
when Esc_D | Esc_S_D =>
Editor.Word.Delete;
when Esc_E | Esc_S_E =>
Editor.Word.End_Of;
when Esc_F | Esc_S_F =>
Editor.Search.Replace_Next (Target => "",
Replacement => "",
Repeat => 1,
Wildcard => False);
when Esc_H | Esc_S_H =>
Editor.Word.Previous;
when Esc_J | Esc_S_J =>
Editor.Word.Next;
when Esc_K | Esc_S_K =>
Editor.Word.Delete_Forward;
when Esc_L | Esc_S_L =>
Editor.Screen.Clear;
when Esc_M | Esc_S_M =>
Editor.Mark.Next;
when Esc_N | Esc_S_N =>
Editor.Cursor.Next (Prompt => True, Underline => True);
when Esc_Q | Esc_S_Q =>
Editor.Key.Prompt (Key_Code => "");
when Esc_R | Esc_S_R =>
Editor.Search.Replace_Previous (Target => "",
Replacement => "",
Repeat => 1,
Wildcard => False);
when Esc_S | Esc_S_S =>
Editor.Search.Replace_Next (Target => "",
Replacement => "",
Repeat => 1,
Wildcard => True);
when Esc_T | Esc_S_T =>
Editor.Word.Transpose;
when Esc_U | Esc_S_U =>
Editor.Cursor.Previous (Prompt => True, Underline => True);
when Esc_V | Esc_S_V =>
Editor.Window.Next;
when Esc_X | Esc_S_X =>
Editor.Macro.Execute;
when Esc_Z | Esc_S_Z =>
Editor.Window.Previous;
when Esc_Backslash =>
Editor.Char.Delete_Spaces;
when Esc_Right_Bracket | Esc_Right_Brace =>
Editor.Region.Finish;
when Esc_Grave | Esc_Tilde =>
Editor.Word.Capitalize;
when Esc_Left_Brace =>
Editor.Region.Start;
--/ if DESIGN_FACILITY then
--// when ESC_BAR =>
--// EDITOR.CHAR.INSERT_STRING("--| ");
--/ end if;
when Esc_Delete =>
Editor.Word.Delete_Backward;
when Esc_Promot =>
Command.Debug;
--/ if DESIGN_FACILITY then
--// when ESC_COMPLT =>
--// DESIGN_IMPLEMENTATION.COMPLETE (INCLUDE_OPTIONAL_ANNOTATIONS => FALSE);
--// when ESC_FORMAT =>
--// DESIGN_IMPLEMENTATION.FORMAT;
--/ end if;
when Esc_Up =>
What.Home_Library;
when Esc_Left =>
Editor.Cursor.Previous (Prompt => True, Underline => True);
when Esc_Right =>
Editor.Cursor.Next (Prompt => True, Underline => True);
when Esc_Back_Tab =>
Editor.Char.Tab_Backward;
when Esc_F1 =>
Debug.Run (Stop_At => Debug.Local_Statement);
when Esc_F2 =>
Debug.Activate (Breakpoint => 0);
when Esc_F3 =>
Debug.Propagate (Name => "<SELECTION>",
In_Task => "",
At_Location => "");
when Esc_F4 =>
Common.Enclosing (In_Place => False, Library => True);
when Esc_F5 =>
Editor.Image.Find ("Help Window");
when Esc_F6 =>
Compilation.Promote (Unit => "<IMAGE>",
Scope => Compilation.All_Parts,
Goal => Compilation.Installed,
Limit => "<WORLDS>",
Effort_Only => False,
Response => "<PROFILE>");
when Esc_F7 =>
Compilation.Demote (Unit => "<SELECTION>",
Goal => Compilation.Source,
Limit => "<WORLDS>",
Effort_Only => False,
Response => "<PROFILE>");
when Esc_F9 =>
Ada.Show_Usage (Name => "<CURSOR>",
Global => False,
Limit => "<WORLDS>",
Closure => False);
when Esc_F10 =>
Common.Clear_Underlining;
when Esc_F11 =>
Job.Connect (0);
when Esc_F12 =>
What.Users (All_Users => True);
--/ if DESIGN_FACILITY then
--// when ESC_NUMERIC_1 =>
--// DESIGN_IMPLEMENTATION.DEFINITION (IN_PLACE => FALSE,VISIBLE => TRUE);
--// when ESC_NUMERIC_2 =>
--// DESIGN_IMPLEMENTATION.SHOW_USAGE (IN_WORLD => "<CURSOR>");
--// when ESC_NUMERIC_3 =>
--// DESIGN_IMPLEMENTATION.EXPLAIN;
--// when ESC_NUMERIC_4 =>
--// DESIGN_IMPLEMENTATION.ENCLOSING (IN_PLACE => FALSE);
--/ end if;
--/ if MAIL then
--// when ESC_DASH =>
--// MAIL.FORWARD;
--// when ESC_DOT =>
--// MAIL.SEND;
--// when ESC_ENTER =>
--// MAIL.EDIT (MAILBOX => "MAIN",FOR_USER => "");
--// when ESC_NUMERIC_COMMA =>
--// MAIL.REPLY (TO_ALL => FALSE);
--/ end if;
when C_F2 =>
Debug.Remove (Breakpoint => 0, Delete => False);
when C_F3 =>
Debug.Stack;
when C_F4 =>
Common.Enclosing (In_Place => False, Library => False);
when C_F6 =>
Compilation.Make (Unit => "<IMAGE>",
Scope => Compilation.All_Parts,
Goal => Compilation.Coded,
Limit => "<WORLDS>",
Effort_Only => False,
Response => "<PROFILE>");
when C_F7 =>
Ada.Source_Unit;
when C_F9 =>
Ada.Show_Usage (Name => "<CURSOR>",
Global => True,
Limit => "<ALL_WORLDS>",
Closure => False);
when C_F10 =>
Ada.Show_Unused (In_Unit => "<IMAGE>",
Check_Other_Units => False);
when C_F12 =>
What.Object (Name => "<IMAGE>");
when Esc_C_F1 =>
Debug.Task_Display;
when Esc_C_F2 =>
Debug.Show;
when Esc_C_F4 =>
Common.Enclosing (In_Place => True, Library => False);
when Esc_C_F5 =>
Access_List.Display (For_Object => "<CURSOR>");
when Esc_C_F6 =>
Compilation.Make (Unit => "<IMAGE>",
Scope => Compilation.Load_Views,
Goal => Compilation.Coded,
Limit => "<ALL_WORLDS>",
Effort_Only => False,
Response => "<PROFILE>");
when Esc_C_F7 =>
Ada.Withdraw;
when Esc_C_F9 =>
Ada.Create_Private;
when Esc_C_F10 =>
Ada.Show_Unused (In_Unit => "<IMAGE>",
Check_Other_Units => True);
when Esc_C_F12 =>
What.Locks (Name => "<IMAGE>");
when others =>
null;
end case;
end case;
end Facit_Commands;8
1