|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 1021530 (0xf965a) Types: TextFile Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000 └─ ⟦cfc2e13cd⟧ »Space Info Vol 2« └─⟦1572da286⟧ └─⟦this⟧ └─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000 └─ ⟦5a81ac88f⟧ »Space Info Vol 1« └─⟦dfc3cbe4d⟧ └─⟦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; exception when others => if This_Object_Subclass = Text then This_Kind := Text_File; else This_Kind := Other_Kind; end if; 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 := 0; 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 function Default_Handle (Activity : Activity_Id := Current) return Activity_Handle; -- for use by loader 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 procedure Remove_Subsystem (Subsystem : Subsystem_Id; Handle : Activity_Handle); -- Remove a subsystem from the domain of an activity function Has_Subsystem (Subsystem : Subsystem_Id; Handle : Activity_Handle) return Boolean; -- Test subsystem's membership in domain of an activity. 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; Default_Handle_Undefined : exception; -- raised by Default_Handle 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; 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