|
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: 56320 (0xdc00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Build, package body Extensions_Support, package body Imports, seg_0211de
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
with Cmvc;
with Compilation_Interface;
with Debug_Tools;
with Directory_Tools;
with Download_Times;
with Import_Interface;
with Library;
with Library_Interface;
with Log;
with Polymorphic_Io;
with Profile;
with Remote_Links;
with String_Utilities;
with Switch_Implementation;
with Time_Utilities;
with Utilities;
package body Extensions_Support is
package Dtable renames Download_Times.Table;
package Link_Table renames Remote_Links.Link_Table;
package View_Table renames Remote_Links.View_Table;
package Ci renames Compilation_Interface;
package Dt renames Directory_Tools;
package Du renames Utilities.Directory_Utilities;
package Li renames Library_Interface;
package Naming renames Directory.Naming;
package Object renames Dt.Object;
package Pio renames Polymorphic_Io;
package Rci renames Remote_Command_Interface;
package Rsu renames Utilities.Rci_Switch_Utilities;
package Si renames Switch_Implementation;
package Ss renames Simple_Status;
package Su renames String_Utilities;
Debugging : Boolean := False;
Target_Key : constant String := "I386_Unix_Als_Xt";
-- Maximum length of a remote command.
Max_Command_Length : Natural := 254;
-- Default suffix of a family directory name.
Family_Suffix : constant String := "_f/";
-- The name of this switch is defined in Get_Operational_Info.
Family_Name_Switch : constant String :=
Target_Key & "_User_Set_Family_Name";
function "=" (L, R : Directory.Object) return Boolean renames Directory."=";
function "=" (L, R : Directory.Error_Status) return Boolean
renames Directory."=";
function Problem (Status : Ss.Condition;
Trace_Command : Boolean) return Boolean is
begin
if Ss.Error (Status => Status,
Level => Ss.Problem) then
if Debugging or else Trace_Command then
Log.Put_Line (Message => "#~" & Ss.Message (Status),
Kind => Profile.Negative_Msg);
end if;
return True;
end if;
return False;
end Problem;
function Qt (Str : String) return String is
begin
return " => """ & Str & """";
end Qt;
function Quot (Str : String) return String is
begin
return """" & Str & """";
end Quot;
procedure Rci_Execute_Command (Command_Line : String;
Remote_Connection : Rci.Context;
Status : in out Ss.Condition;
Trace_Command : Boolean) is
begin
Rci.Execute_Command (Command_Line => Command_Line,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Debugging or else Trace_Command);
end Rci_Execute_Command;
procedure Delete_Links_Files (View_Obj : Directory.Object) is
begin
-- Delete the view's Remote_Links file.
Library.Delete (Existing => Remote_Links.File_Name (View_Obj),
Limit => "<DIRECTORIES>",
Response => "<QUIET>");
-- Delete the view's Download_Times file.
Library.Delete (Existing =>
Download_Times.Download_Times_File_Name (View_Obj),
Limit => "<DIRECTORIES>",
Response => "<QUIET>");
end Delete_Links_Files;
function Get_Enclosing_Directory
(Remote_Directory : String) return String is
Last_Slash : Natural := Su.Reverse_Locate ("/", Remote_Directory);
begin
-- Get the name of the Unix directory that immediately encloses a
-- view's Remote_Directory.
if Last_Slash = 0 or else Last_Slash = Remote_Directory'First then
Log.Put_Line ("Can't get the directory " &
"which contains Remote_Directory " &
Quot (Remote_Directory), Profile.Error_Msg);
return "";
end if;
return Remote_Directory (Remote_Directory'First .. Last_Slash - 1);
end Get_Enclosing_Directory;
function Extract_Family_Name (Remote_Directory : String) return String is
Loc : Natural;
begin
-- Extract the default family name from a Remote_Directory string.
Loc := Su.Reverse_Locate (Family_Suffix, Remote_Directory);
if Loc = 0 then
-- The Remote_Directory string doesn't contain a default family
-- directory name.
Log.Put_Line ("Can't find a family directory name in " &
"the Remote_Directory string " &
Quot (Remote_Directory), Profile.Warning_Msg);
return "";
end if;
if Remote_Directory (Remote_Directory'First) /= '/' then
Log.Put_Line ("Remote_Directory name " &
Quot (Remote_Directory) & " must begin with '/'",
Profile.Error_Msg);
return "";
end if;
declare
Head : constant String :=
Remote_Directory (Remote_Directory'First + 1 .. Loc - 1);
Tail : constant String := Remote_Directory
(Loc + 1 .. Remote_Directory'Last);
begin
-- At least 2 directories must precede the family directory.
if Su.Locate ("/", Head) = Su.Reverse_Locate ("/", Head) then
Log.Put_Line ("The family directory name is misplaced in " &
"the Remote_Directory string " &
Quot (Remote_Directory), Profile.Error_Msg);
return "";
end if;
return Remote_Directory (Remote_Directory'First .. Loc - 1);
end;
end Extract_Family_Name;
function Get_Family_Name (Host_View : Directory.Object;
Remote_Directory : String) return String is
begin
if not Directory.Is_Nil (Host_View) then
declare
Family : constant String := Rsu.Value
(Name => Family_Name_Switch,
For_Directory => Host_View);
begin
if Family'Length /= 0 then
-- Use the family name that is already specified in the
-- User_Set_Family_Name switch.
return Family;
end if;
end;
end if;
-- Extract a family name from the given Remote_Directory.
return Extract_Family_Name (Remote_Directory);
end Get_Family_Name;
function Remote_Family (View_Obj : Directory.Object) return String is
-- If the user set it to a non-null value, the name of the remote
-- family directory is obtained from the view's Family_Name library
-- switch. If the switch value is null, we will derive the family name
-- from the view's Remote_Directory name.
Family : constant String := Rsu.Value (Name => Family_Name_Switch,
For_Directory => View_Obj);
begin
if Family'Length /= 0 then
-- Use the family name that is already specified in the switch.
return Family;
end if;
-- Get the view's Remote_Directory so we can extract the family name
-- from it.
declare
View_Name : constant String := Naming.Get_Full_Name (View_Obj);
Remote_Directory_Result : constant Li.String_Result :=
Li.Remote_Directory (View => View_Name);
Remote_Directory : constant String :=
Su.Lower_Case (Remote_Directory_Result.Result
(1 .. Remote_Directory_Result.Size));
begin
if Problem (Remote_Directory_Result.Condition, True) then
Log.Put_Line ("Can't get the remote directory name for view " &
Quot (View_Name), Profile.Error_Msg);
return "";
end if;
-- Extract the family name from the view's Remote_Directory name.
return Extract_Family_Name (Remote_Directory);
end;
end Remote_Family;
procedure Create_Remote_Directory (Remote_Directory : String;
Remote_Connection : Rci.Context;
Status : in out Ss.Condition;
Trace_Command : Boolean) is
Create_Dir_Command : constant String := "mkdir -p " & Remote_Directory;
begin
if Debugging or else Trace_Command then
Log.Put_Line (Message =>
"#~Create_Remote_Directory (Remote_Directory" &
Qt (Remote_Directory) & ")",
Kind => Profile.Sharp_Msg);
end if;
Log.Put_Line (Message =>
"Creating remote directory " & Quot (Remote_Directory),
Kind => Profile.Position_Msg);
Rci_Execute_Command (Command_Line => Create_Dir_Command,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Problem (Status, Trace_Command) then
Log.Put_Line ("Can't create the remote directory " &
Quot (Remote_Directory) & ". " & Ss.Message (Status),
Profile.Error_Msg);
end if;
exception
when others =>
Unhandled_Exception (Status, "Create_Remote_Directory");
end Create_Remote_Directory;
procedure Directory_Exists
(Remote_Directory : String;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition;
Exists : out Boolean;
Trace_Command : Boolean) is
begin
if Debugging or else Trace_Command then
Log.Put_Line (Message => "#~Directory_Exists (Remote_Directory" &
Qt (Remote_Directory) & ")",
Kind => Profile.Sharp_Msg);
end if;
Exists := False;
Rci.File_Exists (The_File => Remote_Directory,
Remote_Connection => Remote_Connection,
Status => Status,
Exists => Exists,
Trace_Command => Debugging or else Trace_Command);
exception
when others =>
Unhandled_Exception (Status, "Directory_Exists");
end Directory_Exists;
package Build is
procedure Build_Libraries (View_Obj : Directory.Object;
Remote_Machine : String;
Remote_Directory : String;
Remote_Program_Library : String;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean);
procedure Destroy_Library
(Host_View : Directory.Object;
Remote_Directory : String;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean);
end Build;
package Imports is
procedure Batch_Import_Units
(Host_File_Id : Io.File_Type;
Imported_Units : Compilation_Interface.Unit_List;
Into_View : Directory.Object;
Remote_Directory : String;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean);
procedure Import_Units
(Imported_Units : Compilation_Interface.Unit_List;
Into_View : Directory.Object;
Remote_Directory : String;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean);
procedure Perform_Remote_Import
(Host_View : String;
Views_To_Import : Directory.Naming.Iterator;
Remote_Machine : String;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean);
procedure Remove_Remote_Import
(View_To_Remove : Directory.Object;
From_View : String;
Remote_Machine : String;
Remote_Directory : String;
Remote_Connection : Remote_Command_Interface.Context;
Destroying_Library : Boolean;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean);
end Imports;
package body Build is separate;
package body Imports is separate;
------------------------------------------------------------
function Is_True (For_Switch : String;
Enclosing_View_Name : String) return Boolean is
Switch_Handle : Pio.Handle;
Pio_Status : Pio.Error_Status;
Value : Boolean := False;
begin
Pio.Open (The_Handle => Switch_Handle,
Mode => Pio.Read_Only,
File_Name => Enclosing_View_Name & ".State.Compiler_Switches",
Status => Pio_Status);
if Pio_Status /= Directory.Successful then
Log.Put_Line (Message =>
"Can't open switch file " & Enclosing_View_Name &
".STATE.COMPILER_SWITCHES. Error Status = " &
Directory.Error_Status'Image (Pio_Status),
Kind => Profile.Negative_Msg);
return False;
end if;
Value := Si.Value (Switches => Switch_Handle,
Name => "Rci." & Target_Key & "_" & For_Switch);
Pio.Close (File => Switch_Handle,
Status => Pio_Status);
if Pio_Status /= Directory.Successful then
Log.Put_Line (Message =>
"Can't close switch file " & Enclosing_View_Name &
".STATE.COMPILER_SWITCHES. Error Status = " &
Directory.Error_Status'Image (Pio_Status),
Kind => Profile.Negative_Msg);
return False;
end if;
return Value;
end Is_True;
procedure Rename_Remote_File (Remote_Directory : String;
Remote_Machine : String;
From_Simple_Name : String;
To_Simple_Name : String;
Remote_Connection : Rci.Context;
Status : in out Ss.Condition;
Trace_Command : Boolean) is
Copy_Command : constant String :=
"cp " & Remote_Directory & "/" & From_Simple_Name &
" " & Remote_Directory & "/" & To_Simple_Name;
Remove_Temp_File_Command : constant String :=
"rm " & Remote_Directory & "/" & From_Simple_Name;
begin
if Debugging or else Trace_Command then
Log.Put_Line (Message =>
"#~Rename_Remote_File (Remote_Directory" &
Qt (Remote_Directory) & ", Remote_Machine" &
Qt (Remote_Machine) & ", From_Simple_Name" &
Qt (From_Simple_Name) & ", To_Simple_Name" &
Qt (To_Simple_Name) & ")",
Kind => Profile.Sharp_Msg);
end if;
-- Copy the file to its new name.
Rci_Execute_Command (Command_Line => Copy_Command,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Problem (Status, Trace_Command) then
Log.Put_Line ("Can't copy file " & Quot (From_Simple_Name) &
" to " & Quot (To_Simple_Name) &
". " & Ss.Message (Status), Profile.Error_Msg);
else
-- Now that we have the copy, we can destroy the original file.
Rci_Execute_Command (Command_Line => Remove_Temp_File_Command,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Problem (Status, Trace_Command) then
Log.Put_Line ("Can't remove the renamed file " &
From_Simple_Name & ". " & Ss.Message (Status),
Profile.Error_Msg);
end if;
end if;
exception
when others =>
Unhandled_Exception (Status, "Rename_Remote_File");
end Rename_Remote_File;
procedure Build_Libraries (View_Obj : Directory.Object;
Remote_Machine : String;
Remote_Directory : String;
Remote_Program_Library : String;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean) is
begin
Build.Build_Libraries (View_Obj => View_Obj,
Remote_Machine => Remote_Machine,
Remote_Directory => Remote_Directory,
Remote_Program_Library => Remote_Program_Library,
Status => Status,
Trace_Command => Trace_Command);
end Build_Libraries;
procedure Destroy_Library
(Host_View : Directory.Object;
Remote_Directory : String;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean) is
begin
Build.Destroy_Library (Host_View => Host_View,
Remote_Directory => Remote_Directory,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
end Destroy_Library;
procedure Batch_Import_Units
(Host_File_Id : Io.File_Type;
Imported_Units : Compilation_Interface.Unit_List;
Into_View : Directory.Object;
Remote_Directory : String;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean) is
begin
Imports.Batch_Import_Units (Host_File_Id => Host_File_Id,
Imported_Units => Imported_Units,
Into_View => Into_View,
Remote_Directory => Remote_Directory,
Status => Status,
Trace_Command => Trace_Command);
end Batch_Import_Units;
procedure Import_Units
(Imported_Units : Compilation_Interface.Unit_List;
Into_View : Directory.Object;
Remote_Directory : String;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean) is
begin
Imports.Import_Units (Imported_Units => Imported_Units,
Into_View => Into_View,
Remote_Directory => Remote_Directory,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
end Import_Units;
procedure Perform_Remote_Import
(Host_View : String;
Views_To_Import : Directory.Naming.Iterator;
Remote_Machine : String;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean) is
begin
Imports.Perform_Remote_Import (Host_View => Host_View,
Views_To_Import => Views_To_Import,
Remote_Machine => Remote_Machine,
Status => Status,
Trace_Command => Trace_Command);
end Perform_Remote_Import;
procedure Remove_Remote_Import
(View_To_Remove : Directory.Object;
From_View : String;
Remote_Machine : String;
Remote_Directory : String;
Remote_Connection : Remote_Command_Interface.Context;
Destroying_Library : Boolean;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean) is
begin
Imports.Remove_Remote_Import (View_To_Remove => View_To_Remove,
From_View => From_View,
Remote_Machine => Remote_Machine,
Remote_Directory => Remote_Directory,
Remote_Connection => Remote_Connection,
Destroying_Library => Destroying_Library,
Status => Status,
Trace_Command => Trace_Command);
end Remove_Remote_Import;
procedure Retrieve_Files (Main_Unit : String;
Executable_Name : String;
Enclosing_View_Name : String;
Remote_Machine : String;
Remote_Directory : String;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean) is
Main : Dt.Object.Handle := Dt.Naming.Resolution (Main_Unit);
Main_Full_Name : constant String := Dt.Naming.Full_Name (Main);
Main_Simple_Name : constant String :=
Su.Lower_Case (Dt.Naming.Simple_Name (Main));
Host_Cui_Name : constant String := Main_Full_Name & "'Body" & ".<Cui>";
Host_Exe_Name : constant String := Main_Full_Name & "'Body" & ".<Exe>";
Host_Lnk_Name : constant String := Main_Full_Name & "'Body" & ".<Lnk>";
Host_Map_Name : constant String := Main_Full_Name & "'Body" & ".<Map>";
Linker_Generated_Exe : String (1 .. 14) := (others => ' ');
Remote_Connection : Rci.Context;
Name_Length : Natural;
Final_Name_Length : Natural;
procedure Upload_File (Switch : String;
Extension : String;
To_Host_File : String;
The_Type : Rci.File_Type;
Status : in out Ss.Condition) is
Remote_File : constant String :=
Linker_Generated_Exe (1 .. Name_Length) & Extension;
begin
if Debugging or else Trace_Command then
Log.Put_Line (Message =>
"#~Upload_File (Switch" &
Qt (Switch) & ", Extension" &
Qt (Extension) & ", To_Host_File" &
Qt (To_Host_File) & ", The_Type => " &
Rci.File_Type'Image (The_Type) & ")",
Kind => Profile.Sharp_Msg);
end if;
if Is_True (Switch, Enclosing_View_Name) then
Log.Put_Line (Message =>
"Uploading file " &
Quot (Remote_Directory & "/" & Remote_File),
Kind => Profile.Positive_Msg);
Rci.Get (Host_File_Name => To_Host_File,
Target_File_Name =>
Remote_Directory & "/" & Remote_File,
Remote_Connection => Remote_Connection,
Status => Status,
The_Type => The_Type,
Trace_Command => Debugging or else Trace_Command);
if Problem (Status, Trace_Command) then
Set_Status (Message => "Can't upload remote file " &
Quot (Remote_Directory &
"/" & Remote_File) &
" to " & To_Host_File,
Status => Status);
return;
end if;
end if;
if Final_Name_Length > 10 and Executable_Name = "" then
Rename_Remote_File
(Remote_Directory => Remote_Directory,
Remote_Machine => Remote_Machine,
From_Simple_Name => Remote_File,
To_Simple_Name => Main_Simple_Name & Extension,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Problem (Status, Trace_Command) then
Set_Status (Message =>
"Can't rename remote file " &
Quot (Remote_File) & " as " &
Quot (Main_Simple_Name & Extension),
Status => Status);
return;
end if;
end if;
end Upload_File;
begin
if Debugging or else Trace_Command then
Log.Put_Line
(Message => "#~Retrieve_Files (Main_Unit" &
Qt (Main_Unit) & ", Executable_Name" &
Qt (Executable_Name) & ", Enclosing_View_Name" &
Qt (Enclosing_View_Name) & ", Remote_Machine" &
Qt (Remote_Machine) & ", Remote_Directory" &
Qt (Remote_Directory) & ")",
Kind => Profile.Sharp_Msg);
end if;
Log.Put_Line
(Message => "Entering Retrieve_Files",
Kind => Profile.Position_Msg);
--
-- If the user specified executable name is > 14 chars, then the link
-- operation on the target will fail. If the Ada simple name of the
-- main unit is greater than 10 characters, then the Alsys compiler
-- will truncate that name to 10 characters.
--
if Executable_Name /= "" then
-- Use the given Executable_Name.
Name_Length := Executable_Name'Length;
Final_Name_Length := Name_Length;
if Name_Length > 14 then
Log.Put_Line (Message => "Maximum length of executable name " &
Quot (Executable_Name) &
" is 14 characters",
Kind => Profile.Negative_Msg);
Set_Status (Status => Status,
Message => "Executable name " &
Quot (Executable_Name) &
" is too long");
return;
end if;
-- This will fail if Name_Length > 14.
Linker_Generated_Exe (1 .. Name_Length) :=
Executable_Name (1 .. Name_Length);
else
Final_Name_Length := Main_Simple_Name'Length;
if Main_Simple_Name'Length > 10 then
-- Truncate the name to 10 characters.
Name_Length := 10;
else
-- We can use the name as it is.
Name_Length := Main_Simple_Name'Length;
end if;
Linker_Generated_Exe (1 .. Name_Length) :=
Su.Lower_Case (Main_Simple_Name (1 .. Name_Length));
end if;
Rci.Acquire (Remote_Connection => Remote_Connection,
Status => Status,
Target_Key => Target_Key,
Remote_Machine => Remote_Machine,
Trace_Command => Debugging or else Trace_Command);
if Problem (Status, Trace_Command) then
Set_Status
("Can't acquire a connection to " & Remote_Machine, Status);
return;
end if;
-- Retrieve the Cui File
--
Upload_File (Switch => "Get_Cui_File",
Extension => ".cui",
To_Host_File => Host_Cui_Name,
The_Type => Rci.Binary,
Status => Status);
if Problem (Status, Trace_Command) then
Set_Status (Status => Status,
Message => "Can't retrieve the Cui File");
else
-- Retrieve the Map File
--
Upload_File (Switch => "Get_Binder_Listing",
Extension => ".map",
To_Host_File => Host_Map_Name,
The_Type => Rci.Text,
Status => Status);
if Problem (Status, Trace_Command) then
Set_Status
(Status => Status,
Message => "Can't retrieve the Binder listing file");
else
-- Retrieve the Lnk File
--
Upload_File (Switch => "Get_Lnk_File",
Extension => ".lnk",
To_Host_File => Host_Lnk_Name,
The_Type => Rci.Text,
Status => Status);
if Problem (Status, Trace_Command) then
Set_Status (Status => Status,
Message => "Can't retrieve the LNK file");
else
-- Retrieve the Executable File
--
Upload_File (Switch => "Get_Executable_File",
Extension => "",
To_Host_File => Host_Exe_Name,
The_Type => Rci.Binary,
Status => Status);
if Problem (Status, Trace_Command) then
Set_Status
(Status => Status,
Message => "Can't retrieve the Executable file");
end if;
end if;
end if;
end if;
exception
when others =>
Unhandled_Exception (Status, "Retrieve_Files");
end Retrieve_Files;
procedure Set_Status (Message : String;
Status : in out Simple_Status.Condition;
Severity : Simple_Status.Condition_Class :=
Simple_Status.Problem;
Error_Type : String := "Library_Extensions Error") is
begin
Ss.Create_Condition (Status => Status,
Error_Type => Error_Type,
Message => Message,
Severity => Severity);
end Set_Status;
procedure Unhandled_Exception (Status : in out Simple_Status.Condition;
Routine : String) is
begin
Set_Status (Message => "Exception " & Debug_Tools.Get_Exception_Name &
" was caught in " & Routine,
Status => Status,
Error_Type => "Unhandled exception ");
end Unhandled_Exception;
procedure Close_Download_File (The_Handle : in out Dtable.Handle) is
begin
Dtable.Close (The_Handle);
exception
when others =>
null;
end Close_Download_File;
function Get_Download_Time
(Unit_Obj : Directory.Object) return Calendar.Time is
The_Time : Calendar.Time;
The_Handle : Dtable.Handle;
Element_To_Match : Download_Times.Table_Entry;
Element_From_File : Download_Times.Table_Entry;
Element_File_Position : Dtable.File_Position;
Next_Position : Dtable.File_Position;
begin
Dtable.Open (The_Handle, Download_Times.Download_Times_File_Name
(Du.Get_View (Unit_Obj, Profile.Get)),
Dtable.Read);
-- Open the Download_Times table in the view to which this object
-- belongs.
Element_To_Match.Obj := Unit_Obj;
Element_To_Match.Time := Calendar.Clock;
Dtable.Lookup (The_Handle, Element_To_Match, Element_From_File,
Element_File_Position, Next_Position);
-- Look in the table for the specified directory object.
if Dtable.Is_Nil (The_Position => Element_File_Position) then
-- No download time has been entered for our unit, so assume the
-- current time.
The_Time := Calendar.Clock;
else
-- Use the download time from our unit's table entry.
The_Time := Element_From_File.Time;
end if;
Close_Download_File (The_Handle);
return The_Time;
exception
when others =>
Close_Download_File (The_Handle);
Log.Put_Line ("An exception was raised while getting the " &
"download time for a unit", Profile.Warning_Msg);
return Calendar.Clock;
end Get_Download_Time;
procedure Set_Download_Time (Unit_Obj : Directory.Object;
Time : Calendar.Time) is
The_Handle : Dtable.Handle;
Element_To_Match : Download_Times.Table_Entry;
Eleent_From_File : Download_Times.Table_Entry;
Element_File_Position : Dtable.File_Position;
Next_Position : Dtable.File_Position;
begin
Dtable.Open (The_Handle, Download_Times.Download_Times_File_Name
(Du.Get_View (Unit_Obj, Profile.Get)),
Dtable.Read_Write);
-- Open the Download_Times table in the view to which this object
-- belongs. If the table doesn't exist, it will be created (and it
-- will be empty).
Element_To_Match.Obj := Unit_Obj;
Element_To_Match.Time := Time;
Dtable.Lookup (The_Handle, Element_To_Match, Element_From_File,
Element_File_Position, Next_Position);
-- Look in the table for the specified directory object.
if Dtable.Is_Nil (The_Position => Element_File_Position) then
-- It isn't there, so add it.
Dtable.Update (The_Handle, Element_To_Match, Next_Position);
else
-- We found it, so update its table entry.
Dtable.Update (The_Handle, Element_To_Match, Element_File_Position);
end if;
Close_Download_File (The_Handle);
exception
when others =>
Close_Download_File (The_Handle);
Log.Put_Line ("An exception was raised while setting the " &
"download time for a unit", Profile.Warning_Msg);
end Set_Download_Time;
function Discard_Units_From_Same_View
(Units : Compilation_Interface.Unit_List;
Host_Unit : Directory.Object)
return Compilation_Interface.Unit_List is
View_Obj : Directory.Object;
Filtered_Units : Ci.Unit_List (Units.Data'Length);
Next_Entry : Integer := Filtered_Units.Data'First - 1;
Null_Units : Ci.Unit_List (0);
begin
if Units.Size = 0 then
return Null_Units;
end if;
View_Obj := Du.Get_View (Host_Unit, Profile.Get);
Filtered_Units.Condition := Units.Condition;
for Index in Units.Data'First .. Units.Data'Last loop
if Directory."/=" (View_Obj, Du.Get_View (Units.Data (Index),
Profile.Get)) then
Next_Entry := Next_Entry + 1;
Filtered_Units.Data (Next_Entry) := Units.Data (Index);
end if;
end loop;
-- Collect into an array all units not belonging to the same view as
-- the host unit.
if Next_Entry >= Filtered_Units.Data'First then
-- The filtered list is non empty.
declare
Return_Units : Ci.Unit_List (Next_Entry -
Filtered_Units.Data'First + 1);
begin
Return_Units.Condition := Filtered_Units.Condition;
Return_Units.Data :=
Filtered_Units.Data
(Filtered_Units.Data'First .. Next_Entry);
-- Copy back to an array of the proper size and return.
return Return_Units;
end;
end if;
return Null_Units;
end Discard_Units_From_Same_View;
procedure Check_Family (View_Obj : Directory.Object;
Remote_Machine : String;
Remote_Directory : String;
Status : in out Simple_Status.Condition) is
Family_Name : constant String :=
Get_Family_Name (Host_View => View_Obj,
Remote_Directory => Remote_Directory);
begin
if Family_Name'Length = 0 then
if Directory.Is_Nil (View_Obj) then
Set_Status (Message => "Can't extract a family name from " &
"the specified remote directory " &
Quot (Remote_Directory),
Status => Status,
Severity => Ss.Problem);
else
Set_Status (Message =>
"Can't get a valid family name for view " &
Naming.Get_Full_Name (View_Obj),
Status => Status,
Severity => Ss.Fatal);
end if;
end if;
end Check_Family;
end Extensions_Support;
nblk1=36
nid=0
hdr6=6c
[0x00] rec0=21 rec1=00 rec2=01 rec3=074
[0x01] rec0=01 rec1=00 rec2=36 rec3=03e
[0x02] rec0=1e rec1=00 rec2=02 rec3=02a
[0x03] rec0=00 rec1=00 rec2=35 rec3=010
[0x04] rec0=1f rec1=00 rec2=03 rec3=054
[0x05] rec0=1a rec1=00 rec2=04 rec3=08e
[0x06] rec0=18 rec1=00 rec2=05 rec3=074
[0x07] rec0=17 rec1=00 rec2=06 rec3=026
[0x08] rec0=1c rec1=00 rec2=07 rec3=032
[0x09] rec0=17 rec1=00 rec2=08 rec3=07c
[0x0a] rec0=18 rec1=00 rec2=09 rec3=02c
[0x0b] rec0=00 rec1=00 rec2=34 rec3=022
[0x0c] rec0=16 rec1=00 rec2=0a rec3=03c
[0x0d] rec0=17 rec1=00 rec2=0b rec3=06a
[0x0e] rec0=1b rec1=00 rec2=0c rec3=02e
[0x0f] rec0=16 rec1=00 rec2=0d rec3=050
[0x10] rec0=13 rec1=00 rec2=0e rec3=03c
[0x11] rec0=1a rec1=00 rec2=0f rec3=092
[0x12] rec0=01 rec1=00 rec2=33 rec3=004
[0x13] rec0=19 rec1=00 rec2=10 rec3=03a
[0x14] rec0=13 rec1=00 rec2=11 rec3=064
[0x15] rec0=14 rec1=00 rec2=12 rec3=01e
[0x16] rec0=16 rec1=00 rec2=13 rec3=074
[0x17] rec0=15 rec1=00 rec2=14 rec3=010
[0x18] rec0=12 rec1=00 rec2=15 rec3=07e
[0x19] rec0=16 rec1=00 rec2=16 rec3=024
[0x1a] rec0=14 rec1=00 rec2=17 rec3=004
[0x1b] rec0=11 rec1=00 rec2=18 rec3=032
[0x1c] rec0=11 rec1=00 rec2=19 rec3=086
[0x1d] rec0=02 rec1=00 rec2=32 rec3=016
[0x1e] rec0=14 rec1=00 rec2=1a rec3=072
[0x1f] rec0=00 rec1=00 rec2=31 rec3=00c
[0x20] rec0=14 rec1=00 rec2=1b rec3=03a
[0x21] rec0=15 rec1=00 rec2=1c rec3=06e
[0x22] rec0=18 rec1=00 rec2=1d rec3=028
[0x23] rec0=14 rec1=00 rec2=1e rec3=046
[0x24] rec0=00 rec1=00 rec2=30 rec3=00c
[0x25] rec0=1c rec1=00 rec2=1f rec3=01a
[0x26] rec0=1b rec1=00 rec2=20 rec3=038
[0x27] rec0=19 rec1=00 rec2=21 rec3=004
[0x28] rec0=18 rec1=00 rec2=22 rec3=050
[0x29] rec0=1b rec1=00 rec2=23 rec3=038
[0x2a] rec0=1a rec1=00 rec2=24 rec3=068
[0x2b] rec0=00 rec1=00 rec2=2f rec3=018
[0x2c] rec0=1e rec1=00 rec2=25 rec3=016
[0x2d] rec0=00 rec1=00 rec2=2e rec3=002
[0x2e] rec0=16 rec1=00 rec2=26 rec3=05a
[0x2f] rec0=00 rec1=00 rec2=2d rec3=012
[0x30] rec0=1d rec1=00 rec2=27 rec3=00a
[0x31] rec0=00 rec1=00 rec2=2c rec3=010
[0x32] rec0=17 rec1=00 rec2=28 rec3=048
[0x33] rec0=01 rec1=00 rec2=2b rec3=008
[0x34] rec0=19 rec1=00 rec2=29 rec3=042
[0x35] rec0=10 rec1=00 rec2=2a rec3=000
tail 0x2151cafa0838d6b0fa013 0x42a00088462065003