|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 39936 (0x9c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Batch_Extensions, seg_0211bc
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
with Batch_Interface;
with Calendar;
with Compilation_Interface;
with Debug_Tools;
with Extensions_Support;
with Library_Interface;
with Log;
with Object_Class;
with Profile;
with Remote_Command_Interface;
with String_Utilities;
with Target_Dependent_Interface;
with Unit_Interface;
with Utilities;
package body Batch_Extensions is
package Bi renames Batch_Interface;
package Ci renames Compilation_Interface;
package Dt renames Directory_Tools;
package Du renames Utilities.Directory_Utilities;
package Es renames Extensions_Support;
package Li renames Library_Interface;
package Naming renames Directory.Naming;
package Rsu renames Utilities.Rci_Switch_Utilities;
package Ss renames Simple_Status;
package Su renames String_Utilities;
package Tdi renames Target_Dependent_Interface;
package Ui renames Unit_Interface;
This_Target : constant String := "I386_Unix_Als_Xt";
Debugging : Boolean := False;
Generate_Batch_Compile_Commands : Boolean := False;
procedure Io_Put_Line (File : Io.File_Type;
Item : String) is
begin
if Debugging then
Log.Put_Line ("Batch file <= """ & Item & """", Profile.At_Msg);
end if;
Io.Put_Line (File, Item);
end Io_Put_Line;
procedure Set_Status (Status : in out Ss.Condition;
Error_Type : String := "RCI Batch_Extensions error";
Message : String;
Severity : Ss.Condition_Class := Ss.Problem) is
begin
Ss.Create_Condition (Status => Status,
Error_Type => Error_Type,
Message => Message,
Severity => Severity);
end Set_Status;
procedure Unhandled_Exception (Status : in out Ss.Condition;
Routine : String) is
begin
Set_Status (Status => Status,
Error_Type => "Unhandled exception ",
Message => Debug_Tools.Get_Exception_Name &
" caught in " & Routine);
end Unhandled_Exception;
-- Generate a command to set the context on the target for the given
-- Current_Object.
procedure Generate_Context_Change_Command
(Host_File_Id : Io.File_Type;
Current_Object : Directory.Object;
Target_Key : String;
Status : in out Ss.Condition) is
Remote_Directory : constant Li.String_Result :=
Li.Remote_Directory
(Naming.Get_Full_Name (Du.Get_View (Current_Object, Profile.Get)),
Profile.Get);
begin
if Ss.Error (Remote_Directory.Condition) then
Log.Put_Line
("Error in getting the remote directory name for unit " &
Naming.Unique_Full_Name (Current_Object), Profile.Error_Msg);
Status := Remote_Directory.Condition;
return;
end if;
declare
-- Generate the ("cd") command to set the remote context.
Context_Command : constant String :=
Tdi.Build_Context_Command (Target_Key,
Remote_Directory.Result, "");
begin
if Context_Command /= "" then
-- Put the context command into the script.
--** cd **
Io_Put_Line (Host_File_Id, Context_Command);
end if;
end;
end Generate_Context_Change_Command;
-- Returns True if the given Unit is a main program.
function Is_Main_Program (Unit : Directory.Object) return Boolean is
Name : constant String := Naming.Unique_Full_Name (Unit);
Iter : Naming.Iterator;
begin
Iter := Du.Get_Objects (Name & "'C(Main_Body)", Profile.Get);
if Naming."=" (Iter, Naming.Nil) then
return False;
else
return True;
end if;
exception
when others =>
return False;
end Is_Main_Program;
-- Generate the batch command to compile a unit.
function Build_Batch_Compile_Command
(Target_Key : String;
Current_Object : Directory.Object;
Remote_Unit_Name : String;
Response : Profile.Response_Profile) return String is
Pre_Options : constant String :=
Tdi.Compiler_Pre_Options (Target_Key, Current_Object, Response);
Post_Options : constant String :=
Tdi.Compiler_Post_Options (Target_Key, Current_Object, Response);
Interactive_Command : constant String :=
Tdi.Build_Compiltion_Command (Target_Key => Target_Key,
Unit_Name => Remote_Unit_Name,
Pre_Options => Pre_Options,
Post_Options => Post_Options);
Loc : Natural;
Local_Status : Ss.Condition;
begin
-- Interactive_Command will be of the form:
-- ada compile library=adalib user_switch_options
-- source= remote_unit_name user_post_options
-- We will strip off the command prefix, including the 'library'
-- option, and then we will put back the command "compile" (or its
-- abbreviation).
--
-- Note that this code may need to be changed if Get_Operational_Info
-- is changed.
Loc := Su.Locate ("=adalib", Interactive_Command);
if Loc = 0 then
Log.Put_Line ("Error in parsing the compile command for unit " &
Naming.Unique_Full_Name (Current_Object),
Profile.Error_Msg);
return "";
end if;
-- or return "c" & Interactive_Command
return "compile" & Interactive_Command
(Loc + 7 .. Interactive_Command'Last);
exception
when others =>
Unhandled_Exception (Local_Status, "Build_Batch_Compile_Command");
return "";
end Build_Batch_Compile_Command;
procedure Generate_Acquire_Commands
(Host_File_Id : Io.File_Type;
Host_Unit : Directory.Object;
Remote_Directory : String;
-- Target_Key : String;
Status : in out Simple_Status.Condition) is
Prereqs : constant Ci.Unit_List :=
Ci.Promotion_Prerequisites (The_Unit => Host_Unit,
Response => Profile.Nil);
With_List : constant Ci.Unit_List :=
Es.Discard_Units_From_Same_View (Prereqs, Host_Unit);
-- This is a list of all units in other views that the current host
-- unit depends upon.
Unit_Obj : Directory.Object;
Current_View_Obj : Directory.Object :=
Du.Get_View (Host_Unit, Profile.Get);
Trace_On : constant Boolean := Rsu.Trace_On (Current_View_Obj);
begin
if not Directory."=" (Directory.Get_Class (Host_Unit),
Object_Class.Ada) then
-- Skip any non-Ada objects (like secondarys). Actually we won't
-- have been able to get their Promotion_Prerequisites above.
return;
end if;
if Rsu.Is_Host_Only (Current_View_Obj) then
-- No action if view is Host_Only.
Ss.Create_Condition (Status, "", "", Ss.Normal);
return;
end if;
--
-- For each unit U that is in the compilation closure of the unit that
-- is being compiled, generate the commands to enter a link to the
-- corresponding remote unit into the current remote library.
if Ss.Error (Prereqs.Condition) then
Status := Prereqs.Condition;
return;
end if;
if Debugging then
-- Print the names of the prerequisite units.
for Index in Prereqs.Data'First .. Prereqs.Data'Last loop
Unit_Obj := Prereqs.Data (Index);
Log.Put_Line ("#~~ Prereqs" & Integer'Image (Index) &
": " & Naming.Unique_Full_Name (Unit_Obj),
Profile.Note_Msg);
end loop;
end if;
if Ss.Error (With_List.Condition) then
Status := With_List.Condition;
return;
end if;
-- Set the unit's download time to be the current time.
Es.Set_Download_Time (Host_Unit, Calendar.Clock);
if With_List.Size /= 0 then
-- Generate the commands to import each of the prerequisite units
-- into Host_Unit's remote directory.
Es.Batch_Import_Units (Host_File_Id => Host_File_Id,
Imported_Units => With_List,
Into_View => Current_View_Obj,
Remote_Directory => Remote_Directory,
Status => Status,
Trace_Command => Trace_On);
end if;
exception
when others =>
Unhandled_Exception (Status, "Generate_Acquire_Commands");
raise;
end Generate_Acquire_Commands;
-- Generate the compile commands for a set of Host_Units.
procedure Generate_Compile_Commands (Host_File_Id : Io.File_Type;
Host_Units : Dt.Object.Iterator;
Target_Key : String;
Status : in out Ss.Condition) is
Host_Units_Iter : Dt.Object.Iterator := Host_Units;
Current_Object : Directory.Object;
Current_View : Directory.Object;
Previous_View : Directory.Object := Directory.Nil;
Has_Secondary : Boolean := False;
First_Unit : Boolean := True;
Error_Status : Directory.Error_Status;
Compile_Pre_Command : constant String :=
Tdi.Compiler_Pre_Command (Target_Key);
Resp : Profile.Response_Profile := Profile.Get;
begin
Dt.Object.Reset (Host_Units_Iter);
-- Reset the object iterator.
while not Dt.Object.Done (Host_Units_Iter) loop
Dt.Object.Low_Level.Get_Object (Dt.Object.Value (Host_Units_Iter),
Current_Object, Error_Status);
-- Convert the current handle to a directory object.
if Directory."/=" (Error_Status, Directory.Successful) then
Log.Put_Line ("Error in getting an object from its handle",
Profile.Error_Msg);
return;
end if;
Current_View := Du.Get_View (Current_Object, Resp);
-- First generate all secondary commands for this host unit.
Ui.Has_Secondary (Current_Object, Has_Secondary, Status, Resp);
-- Check if the current object has any secondary referencers.
if Has_Secondary and then not Ui.Process_Primary
(Current_Object, Resp) then
-- Do not generate commands for an ADA primary that has one or
-- more secondarys unless it has Process_Primary set to True.
Log.Put_Line ("Not generating compile commands " &
"for Primary " &
Naming.Unique_Full_Name (Current_Object),
Profile.Note_Msg);
else
Log.Put_Line ("Generating compile commands for " &
Naming.Unique_Full_Name (Current_Object),
Profile.Note_Msg);
if Directory."/=" (Current_View, Previous_View) then
if not First_Unit then
-- We must change the remote context. End the
-- redirect-input list so we can start another list.
--** quit **
Io_Put_Line (Host_File_Id, "quit");
-- or Io_Put_Line (Host_File_Id, "q");
--** ! **
Io_Put_Line (Host_File_Id, "!");
end if;
--** cd **
Generate_Context_Change_Command
(Host_File_Id, Current_Object, Target_Key, Status);
-- Generate the command to set the remote context to the
-- unit's remote directory.
if Compile_Pre_Command /= "" then
-- Put in the pre-command.
--** Pre_Command **
Io_Put_Line (Host_File_Id, Compile_Pre_Command);
end if;
--** ada <<! **
Io_Put_Line (Host_File_Id, "ada <<!");
--** default **
Io_Put_Line (Host_File_Id,
"default.compile library=adalib");
-- or Io_Put_Line (Host_File_Id, "d.c li=adalib");
-- or we could just have
--** invoke **
-- Io_Put_Line (Host_File_Id, "invoke inv.tmp");
First_Unit := False;
Previous_View := Current_View;
end if;
-- Generate the rest of the compile command for each unit.
declare
View_Name : constant String :=
Naming.Get_Full_Name (Current_View);
Remote_Unit_Name : constant Ui.String_Result :=
Ui.Remote_Unit_Name (View => View_Name,
The_Unit => Current_Object,
Response => Resp);
Remote_Directory : constant Li.String_Result :=
Li.Remote_Directory (View_Name);
begin
if Ss.Error (Remote_Directory.Condition) then
Log.Put_Line ("Error in getting the remote " &
"directory name for view " & View_Name,
Profile.Error_Msg);
Status := Remote_Directory.Condition;
elsif Ss.Error (Remote_Unit_Name.Condition) then
Log.Put_Line ("Error in getting the remote name for " &
Naming.Unique_Full_Name (Current_Object),
Profile.Error_Msg);
Status := Remote_Unit_Name.Condition;
-- elsif Remote_Unit_Name = "" then
-- Log.Put_Line
-- ("Error while getting the remote unit name for " &
-- Naming.Unique_Full_Name (Current_Object) &
-- " while generating batch compile commands",
-- Profile.Error_Msg);
else
-- We need to include any "acquire" commands that this
-- compilation command requires. Note that we already
-- called "ada" on the remote machine.
--** Note that we are generating 'acquire' commands for
-- only one compile command at a time. It would be
-- more efficient if we could do all the 'acquire's at
-- once and then do all of the 'compile's. That way we
-- would only need to go into the unit_manager once,
-- though we would need to generate 'other' commands to
-- change remote destination libraries.
--** acquire **
Generate_Acquire_Commands
(Host_File_Id => Host_File_Id,
Host_Unit => Current_Object,
Remote_Directory => Remote_Directory.Result,
-- Target_Key => Target_Key,
Status => Status);
-- Put in the compile command for this unit.
--** compile **
Io_Put_Line (Host_File_Id,
Build_Batch_Compile_Command
(This_Target, Current_Object,
Remote_Unit_Name.Result, Resp));
-- The batch compile command will be the interactive
-- compile command (including the user's options)
-- without the initial "ada" and without the constant
-- options that we 'default'ed above.
end if;
end;
end if;
Dt.Object.Next (Host_Units_Iter);
end loop;
if not First_Unit then
-- At least one unit has been processed, so we must specify the end
-- of the redirected input.
--** quit **
Io_Put_Line (Host_File_Id, "quit");
-- or Io_Put_Line (Host_File_Id, "q");
--** ! **
Io_Put_Line (Host_File_Id, "!");
end if;
exception
when others =>
Unhandled_Exception (Status, "Generate_Compile_Commands");
end Generate_Compile_Commands;
-- Generate the commands to process the secondarys for a set of Host_Units.
procedure Generate_Secondary_Commands (Host_File_Id : Io.File_Type;
Host_Units : Dt.Object.Iterator;
Target_Key : String;
Status : in out Ss.Condition) is
Host_Units_Iter : Dt.Object.Iterator := Host_Units;
Current_Object : Directory.Object;
Has_Secondary : Boolean := False;
Error_Status : Directory.Error_Status;
begin
Dt.Object.Reset (Host_Units_Iter);
while not Dt.Object.Done (Host_Units_Iter) loop
Dt.Object.Low_Level.Get_Object (Dt.Object.Value (Host_Units_Iter),
Current_Object, Error_Status);
-- Convert the current handle into a directory object.
if Directory."/=" (Error_Status, Directory.Successful) then
Log.Put_Line ("Error in getting an object from its handle",
Profile.Error_Msg);
return;
end if;
Ui.Has_Secondary (Current_Object, Has_Secondary,
Status, Profile.Get);
-- Check if the current object has any secondary referencers.
if Has_Secondary then
Log.Put_Line ("Generating the secondary commands for " &
Naming.Unique_Full_Name (Current_Object),
Profile.Note_Msg);
-- Set the remote context to the unit's remote directory.
--** cd **
Generate_Context_Change_Command
(Host_File_Id, Current_Object, Target_Key, Status);
if Ss.Error (Status) then
return;
end if;
-- Generate the commands to process the Current_Object's
-- secondarys.
Bi.Generate_Secondary_Commands
(Host_File_Id, Current_Object,
Target_Key, Status, Profile.Get);
if Ss.Error (Status) then
Log.Put_Line ("Error while generating the " &
"secondary commands for Primary unit " &
Naming.Unique_Full_Name (Current_Object),
Profile.Error_Msg);
return;
end if;
end if;
Dt.Object.Next (Host_Units_Iter);
end loop;
exception
when others =>
Unhandled_Exception (Status, "Generate_Secondary_Commands");
end Generate_Secondary_Commands;
-- Generate the link commands for the main programs in a set of Host_Units.
procedure Generate_Link_Commands (Compilation_Script_File : Io.File_Type;
Host_Units : Dt.Object.Iterator;
Target_Key : String;
Status : in out Ss.Condition) is
Host_Units_Iter : Dt.Object.Iterator := Host_Units;
Current_Object : Directory.Object;
Error_Status : Directory.Error_Status;
begin
Dt.Object.Reset (Host_Units_Iter);
-- Reset the iterator.
while not Dt.Object.Done (Host_Units_Iter) loop
Dt.Object.Low_Level.Get_Object (Dt.Object.Value (Hos_Units_Iter),
Current_Object, Error_Status);
-- Convert the current handle into a directory object.
if Directory."/=" (Error_Status, Directory.Successful) then
Log.Put_Line ("Error in getting an object from its handle",
Profile.Error_Msg);
return;
end if;
if Is_Main_Program (Current_Object) then
-- Generate link commands only for the main units.
Log.Put_Line ("Generating link commands for " &
Naming.Unique_Full_Name (Current_Object),
Profile.Note_Msg);
-- Set the remote context to the unit's remote directory.
--** cd **
Generate_Context_Change_Command
(Compilation_Script_File,
Current_Object, Target_Key, Status);
if Ss.Error (Status) then
return;
end if;
-- Generate the link commands for the unit.
--** bind **
Bi.Generate_Link_Commands
(Compilation_Script_File, Current_Object,
Target_Key, Status, Profile.Get);
if Ss.Error (Status) then
Log.Put_Line ("Error while generating the " &
"link commands for " &
Naming.Unique_Full_Name (Current_Object),
Profile.Error_Msg);
return;
end if;
end if;
Dt.Object.Next (Host_Units_Iter);
end loop;
exception
when others =>
Unhandled_Exception (Status, "Generate_Link_Commands");
end Generate_Link_Commands;
procedure Build_Script_Preprocess
(Compilation_Script_File : Io.File_Type;
Move_Script_File : Io.File_Type;
Build_Via_Tape : Boolean;
Host_Units : Directory_Tools.Object.Iterator;
Link_Main_Units : Boolean;
Remote_Machine : String;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition) is
begin
Log.Put_Line ("#~~Build_Script_Preprocess (Build_Via_Tape => " &
Boolean'Image (Build_Via_Tape) & ", Link_Main_Units => " &
Boolean'Image (Link_Main_Units) &
", Remote_Machine => """ & Remote_Machine & """)",
Profile.Sharp_Msg);
if Generate_Batch_Compile_Commands then
return;
end if;
Ss.Initialize (Status);
-- We will not intermix ADA and secondary commands (unlike the
-- interactive mode). This is because we want to compile all ADA units
-- with a single elaboration of the target ADA compiler.
-- Generate all secondary commands first.
Generate_Secondary_Commands (Compilation_Script_File,
Host_Units, This_Target, Status);
if Ss.Error (Status) then
return;
end if;
-- Now we can generate all of the compile commands.
Generate_Compile_Commands (Compilation_Script_File,
Host_Units, This_Target, Status);
if Ss.Error (Status) then
return;
end if;
if Link_Main_Units then
-- Generate link commands for all main units in the list.
Generate_Link_Commands (Compilation_Script_File,
Host_Units, This_Target, Status);
end if;
exception
when others =>
Unhandled_Exception (Status, "Build_Script_Preprocess");
end Build_Script_Preprocess;
procedure Build_Script_Postprocess
(Compilation_Script_File : Io.File_Type;
Move_Script_File : Io.File_Type;
Build_Via_Tape : Boolean;
Host_Units : Directory_Tools.Object.Iterator;
Link_Main_Units : Boolean;
Remote_Machine : String;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition) is
begin
Log.Put_Line (Message => "Executing Build_Script_Postprocess",
Kind => Profile.Note_Msg);
Ss.Initialize (Status);
end Build_Script_Postprocess;
procedure Execute_Script_Preprocess
(Host_Script_Unit : Directory.Object;
Remote_Script_File : String;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition) is
begin
Log.Put_Line (Message => "Executing Execute_Script_Preprocess",
Kind => Profile.Note_Msg);
Ss.Initialize (Status);
end Execute_Script_Preprocess;
procedure Execute_Script_Postprocess
(Host_Script_Unit : Directory.Object;
Remote_Script_File : String;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition) is
begin
Log.Put_Line (Message => "Executing Execute_Script_Postprocess",
Kind => Profile.Note_Msg);
Ss.Initialize (Status);
end Execute_Script_Postprocess;
procedure Upload_Associated_Files_Preprocess
(Units : Directory_Tools.Object.Iterator;
Remote_Machine : String;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition) is
begin
Log.Put_Line (Message => "Executing Upload_Associated_Files_Preprocess",
Kind => Profile.Note_Msg);
Ss.Initialize (Status);
end Upload_Associated_Files_Preprocess;
procedure Upload_Associated_Files_Postprocess
(Units : Directory_Tools.Object.Iterator;
Remote_Machine : String;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition) is
begin
Log.Put_Line (Message =>
"Executing Upload_Associated_Files_Postprocess",
Kind => Profile.Note_Msg);
Ss.Initialize (Status);
end Upload_Associated_Files_Postprocess;
end Batch_Extensions;
nblk1=26
nid=0
hdr6=4c
[0x00] rec0=20 rec1=00 rec2=01 rec3=052
[0x01] rec0=02 rec1=00 rec2=26 rec3=056
[0x02] rec0=1c rec1=00 rec2=02 rec3=044
[0x03] rec0=18 rec1=00 rec2=03 rec3=01a
[0x04] rec0=1a rec1=00 rec2=04 rec3=002
[0x05] rec0=1d rec1=00 rec2=05 rec3=036
[0x06] rec0=00 rec1=00 rec2=25 rec3=002
[0x07] rec0=16 rec1=00 rec2=06 rec3=016
[0x08] rec0=00 rec1=00 rec2=24 rec3=012
[0x09] rec0=19 rec1=00 rec2=07 rec3=054
[0x0a] rec0=1a rec1=00 rec2=08 rec3=01a
[0x0b] rec0=01 rec1=00 rec2=23 rec3=000
[0x0c] rec0=1b rec1=00 rec2=09 rec3=052
[0x0d] rec0=16 rec1=00 rec2=0a rec3=08a
[0x0e] rec0=19 rec1=00 rec2=0b rec3=028
[0x0f] rec0=00 rec1=00 rec2=22 rec3=018
[0x10] rec0=15 rec1=00 rec2=0c rec3=052
[0x11] rec0=15 rec1=00 rec2=0d rec3=03a
[0x12] rec0=15 rec1=00 rec2=0e rec3=000
[0x13] rec0=15 rec1=00 rec2=0f rec3=010
[0x14] rec0=00 rec1=00 rec2=21 rec3=006
[0x15] rec0=12 rec1=00 rec2=10 rec3=01e
[0x16] rec0=10 rec1=00 rec2=11 rec3=03e
[0x17] rec0=15 rec1=00 rec2=12 rec3=076
[0x18] rec0=19 rec1=00 rec2=13 rec3=03c
[0x19] rec0=00 rec1=00 rec2=20 rec3=004
[0x1a] rec0=17 rec1=00 rec2=14 rec3=014
[0x1b] rec0=17 rec1=00 rec2=15 rec3=024
[0x1c] rec0=1c rec1=00 rec2=16 rec3=080
[0x1d] rec0=00 rec1=00 rec2=1f rec3=002
[0x1e] rec0=17 rec1=00 rec2=17 rec3=018
[0x1f] rec0=1d rec1=00 rec2=18 rec3=022
[0x20] rec0=16 rec1=00 rec2=19 rec3=02e
[0x21] rec0=1a rec1=00 rec2=1a rec3=00a
[0x22] rec0=18 rec1=00 rec2=1b rec3=054
[0x23] rec0=19 rec1=00 rec2=1c rec3=01c
[0x24] rec0=14 rec1=00 rec2=1d rec3=07a
[0x25] rec0=07 rec1=00 rec2=1e rec3=001
tail 0x2151caee2838d6ad448e6 0x42a00088462065003