|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: B T
Length: 64181 (0xfab5)
Types: TextFile
Names: »B«
└─⟦516dceb10⟧ Bits:30000751 8mm tape, Rational 1000, RCI_VADS
└─⟦9a14c9417⟧ »DATA«
└─⟦this⟧
with Debug_Tools;
with Library_Interface;
with Log;
with Object_Subclass;
with Profile;
with String_Utilities;
with View_Support;
with Directory_Tools;
with Rcf_Switch_Implementation;
package body Extensions_Support is
package Li renames Library_Interface;
package Rci renames Remote_Command_Interface;
package Ss renames Simple_Status;
package Su renames String_Utilities;
Target_Key : constant String := "M68k_Sunos_Vdx";
function "=" (L, R : Directory.Error_Status) return Boolean
renames Directory."=";
function "=" (L, R : Directory.Object) return Boolean renames Directory."=";
function "=" (L, R : Directory.Subclass) return Boolean
renames Directory."=";
function Qt (Str : String) return String is
begin
return " => """ & Str & """";
end Qt;
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 =>
Debug_Tools.Get_Exception_Name & " caught in " & Routine,
Status => Status,
Error_Type => "Unhandled exception ");
end Unhandled_Exception;
function Is_View (Obj : Directory.Object) return Boolean is
Subclass : Directory.Subclass := Directory.Get_Subclass (Obj);
begin
return (Subclass = Object_Subclass.Spec_View_Subclass) or else
(Subclass = Object_Subclass.Load_View_Subclass) or else
(Subclass = Object_Subclass.Combined_View_Subclass);
end Is_View;
function Get_View (Object : Directory.Object) return Directory.Object is
Obj : Directory.Object := Object;
E_Status : Directory.Error_Status;
Obj_Unit : Directory.Ada.Unit;
begin
if Is_View (Obj) then
return Obj;
end if;
Directory.Control_Point.Enclosing_World (Obj, Obj_Unit, E_Status);
if Directory."/=" (E_Status, Directory.Successful) then
return Directory.Nil;
end if;
Obj := Directory.Ada.Get_Object (Obj_Unit);
if Is_View (Obj) then
return Obj;
else
return Directory.Nil;
end if;
-- if you are here, an error occurred
return Directory.Nil;
end Get_View;
function Get_View (Object_Name : String) return Directory.Object is
Obj : Directory.Object;
Status : Naming.Name_Status;
begin
Naming.Resolve (Object_Name, Obj, Status);
if Naming."/=" (Status, Naming.Successful) then
Log.Put_Line (Object_Name & " not found", Profile.Warning_Msg);
return Directory.Nil;
end if;
return Get_View (Obj);
end Get_View;
function Get_Object (Object_Name : String) return Directory.Object is
Obj : Directory.Object;
Status : Naming.Name_Status;
begin
Naming.Resolve (Object_Name, Obj, Status);
if Naming."/=" (Status, Naming.Successful) then
return Directory.Nil;
end if;
return Obj;
end Get_Object;
function Trace_Flag return Boolean is
begin
return False;
end Trace_Flag;
procedure Do_Import (Remote_Import_Directory : String;
To_View : Directory.Object;
Remote_Connection : Rci.Context;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean) is
View_Name : constant String := Naming.Get_Full_Name (To_View);
Directory_Result : constant Li.String_Result :=
Li.Remote_Directory (View => View_Name);
Remote_Directory : constant String := Directory_Result.Result;
Set_Directory_Command : constant String := "cd " & Remote_Directory;
Add_Import_Cmd : constant String := "a.path -L ";
Add_Import_Command : constant String :=
Add_Import_Cmd & Remote_Directory & " -i " & Remote_Import_Directory;
Exists : Boolean;
procedure Import_Exists (Remote_View : String;
Exists : out Boolean) is
Local_Status : Ss.Condition;
Import_Exists_Command : constant String :=
"a.path>a.path_temp;egrep -s " & Remote_View & " a.path_temp";
begin
if Trace_Command then
Log.Put_Line (Message => "Import_Exists (Remote_View" &
Qt (Remote_View) & ")",
Kind => Profile.Sharp_Msg);
end if;
Exists := False;
if Trace_Command then
Log.Put_Line ("Import_Exists_Command" &
Qt (Import_Exists_Command), Profile.At_Msg);
end if;
Rci.Execute_Command (Command_Line => Import_Exists_Command,
Remote_Connection => Remote_Connection,
Status => Local_Status,
Error_Pattern => "", -- ignored
Parse_Error_Output => False, -- ignored
Parse_Standard_Output => False, -- ignored
Show_Parsed_Output => True, -- ignored
Trace_Command => Trace_Command);
if Ss.Error (Local_Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Local_Status), Profile.At_Msg);
Log.Put_Line ("View """ & Remote_View &
""" has not yet been imported",
Profile.Note_Msg);
end if;
else
if Trace_Command then
Log.Put_Line ("View """ & Remote_View &
""" was previously imported",
Profile.Note_Msg);
end if;
Exists := True;
end if;
end Import_Exists;
begin
if Trace_Command then
Log.Put_Line (Message => "Do_Import (Remote_Import_Directory" &
Qt (Remote_Import_Directory) &
", To_View" & Qt (View_Name) & ")",
Kind => Profile.Sharp_Msg);
end if;
if Ss.Error (Directory_Result.Condition) then
if Trace_Command then
Log.Put_Line (Ss.Message (Directory_Result.Condition),
Profile.Negative_Msg);
end if;
Set_Status ("Can't get remote directory name for view " & View_Name,
Status);
return;
end if;
if Su.Strip (Remote_Directory) = "" then
Log.Put_Line ("Name of remote directory for view " &
View_Name & " is null", Profile.Warning_Msg);
return;
elsif Su.Strip (Remote_Import_Directory) = "" then
Log.Put_Line ("Name of remote library to be imported into view " &
View_Name & " is null", Profile.Warning_Msg);
return;
end if;
if Trace_Command then
Log.Put_Line ("Set_Directory_Command" & Qt (Set_Directory_Command),
Profile.At_Msg);
end if;
Rci.Execute_Command (Command_Line => Set_Directory_Command,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
-- Remote_Directory doesn't exist, so we certainly can't import
-- into it.
if Trace_Command then
Log.Put_Line (Ss.Message (Status), Profile.Warning_Msg);
end if;
Log.Put_Line ("Can't import library " & Remote_Import_Directory &
" into nonexistent remote library " &
Remote_Directory, Profile.Warning_Msg);
Ss.Initialize (Status);
return;
end if;
-- See if the Remote_Import_Directory exists.
Rci.File_Exists (The_File => Remote_Import_Directory,
Remote_Connection => Remote_Connection,
Status => Status,
Exists => Exists,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Status), Profile.Warning_Msg);
end if;
Log.Put_Line ("Can't tell whether remote Ada library """ &
Remote_Import_Directory & """ exists",
Profile.Warning_Msg);
Ss.Initialize (Status);
return;
elsif not Exists then
Log.Put_Line ("Can't import nonexistent remote library " &
Remote_Import_Directory &
" into library " & Remote_Directory,
Profile.Warning_Msg);
return;
end if;
-- Both Remote_Directory and Remote_Import_Directory exist on the
-- remote machine. Is the Remote_Import_Directory already imported?
Import_Exists (Remote_View => Remote_Import_Directory,
Exists => Exists);
if not Exists then
-- This view isn't yet imported, so we will add it now.
if Trace_Command then
Log.Put_Line ("Add_Import_Command" & Qt (Add_Import_Command),
Profile.At_Msg);
end if;
Rci.Execute_Command (Command_Line => Add_Import_Command,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Status), Profile.Negative_Msg);
end if;
Set_Status ("Can't import " & Remote_Import_Directory &
" into remote library " & Remote_Directory, Status);
else
Log.Put_Line ("Remote library " & Remote_Import_Directory &
" has been imported into " & Remote_Directory,
Profile.Positive_Msg);
end if;
else
if Trace_Command then
Log.Put_Line ("Remote library " & Remote_Import_Directory &
" is already imported into " & Remote_Directory,
Profile.Note_Msg);
end if;
end if;
exception
when others =>
Unhandled_Exception (Status, "Do_Import");
end Do_Import;
procedure Refresh_Referencers
(To_View : Directory.Object;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean) is
View_Name : constant String := Naming.Get_Full_Name (To_View);
Directory_Result : constant Li.String_Result :=
Li.Remote_Directory (View => View_Name);
Remote_Directory : constant String := Directory_Result.Result;
Referencer : Directory.Object;
Referencers : constant View_Support.Unit_List :=
View_Support.Get_Referencers (To_View, True);
begin
if Trace_Command then
Log.Put_Line (Message => "Refresh_Referencers (To_View" &
Qt (View_Name) & ")",
Kind => Profile.Sharp_Msg);
end if;
if Ss.Error (Directory_Result.Condition) then
if Trace_Command then
Log.Put_Line (Ss.Message (Directory_Result.Condition),
Profile.Negative_Msg);
end if;
Set_Status ("Can't get remote directory name for view " & View_Name,
Status);
return;
end if;
if Ss.Error (Referencers.Condition) then
if Trace_Command then
Log.Put_Line (Ss.Message (Referencers.Condition),
Profile.Negative_Msg);
end if;
Set_Status ("Can't get referencers for view " & View_Name, Status);
return;
end if;
-- Add To_View's remote directory as an import for each of its
-- referencers on the Sparc.
for Index in 1 .. Referencers.Size loop
Referencer := Referencers.Data (Index);
if Trace_Command then
Log.Put_Line (". Referencers (" & Integer'Image (Index) &
", " & View_Name & ") => " &
Naming.Get_Full_Name (Referencer),
Profile.At_Msg);
end if;
if Referencer /= To_View then
Do_Import (Remote_Import_Directory => Remote_Directory,
To_View => Referencer,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
Log.Put_Line (Ss.Message (Status), Profile.Warning_Msg);
Log.Put_Line ("Can't make " & Remote_Directory &
" a remote import of " &
Naming.Get_Full_Name (Referencer),
Profile.Warning_Msg);
Ss.Initialize (Status);
end if;
end if;
end loop;
end Refresh_Referencers;
procedure Add_Remote_Import
(Imported_View : Directory.Object;
To_View : Directory.Object;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean) is
Import_Name : constant String := Naming.Get_Full_Name (Imported_View);
Import_Result : constant Li.String_Result :=
Li.Remote_Directory (View => Import_Name);
Remote_Import_Directory : constant String := Import_Result.Result;
Referencer : Directory.Object;
Referencers : constant View_Support.Unit_List :=
View_Support.Get_Referencers (To_View, True);
begin
if Trace_Command then
Log.Put_Line (Message =>
"Add_Remote_Import (Imported_View" &
Qt (Import_Name) & ", To_View" &
Qt (Naming.Get_Full_Name (To_View)) & ")",
Kind => Profile.Sharp_Msg);
end if;
if Ss.Error (Import_Result.Condition) then
if Trace_Command then
Log.Put_Line (Ss.Message (Import_Result.Condition),
Profile.Negative_Msg);
end if;
Set_Status ("Can't get remote directory name for imported view " &
Import_Name, Status);
return;
end if;
if Ss.Error (Referencers.Condition) then
if Trace_Command then
Log.Put_Line (Ss.Message (Referencers.Condition),
Profile.Negative_Msg);
end if;
Set_Status ("Can't get referencers for view " &
Naming.Get_Full_Name (To_View), Status);
return;
end if;
if Imported_View = To_View then
return;
end if;
-- Add Imported_View's remote directory to To_View's import list on
-- the Sparc.
Do_Import (Remote_Import_Directory => Remote_Import_Directory,
To_View => To_View,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
Log.Put_Line (Ss.Message (Status), Profile.Warning_Msg);
Log.Put_Line ("Can't make " & Remote_Import_Directory &
" a remote import of " &
Naming.Get_Full_Name (To_View), Profile.Warning_Msg);
Ss.Initialize (Status);
end if;
-- Now add Imported_View's remote directory as an import for each of
-- To_View's referencers on the Sparc.
for Index in 1 .. Referencers.Size loop
Referencer := Referencers.Data (Index);
if Trace_Command then
Log.Put_Line (". Referencers (" & Integer'Image (Index) &
", " & Naming.Get_Full_Name (To_View) &
") => " & Naming.Get_Full_Name (Referencer),
Profile.At_Msg);
end if;
if Referencer /= Imported_View and then Referencer /= To_View then
Do_Import (Remote_Import_Directory => Remote_Import_Directory,
To_View => Referencer,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
Log.Put_Line (Ss.Message (Status), Profile.Warning_Msg);
Log.Put_Line ("Can't make " & Remote_Import_Directory &
" a remote import of " &
Naming.Get_Full_Name (Referencer),
Profile.Warning_Msg);
Ss.Initialize (Status);
end if;
end if;
end loop;
end Add_Remote_Import;
procedure Add_Remote_Imports
(Imported_Views : in out Directory.Naming.Iterator;
To_View : Directory.Object;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean) is
Imports : Naming.Iterator := Imported_Views;
Error_Status : Directory.Error_Status;
Import_Object : Directory.Object;
begin
if Trace_Command then
Log.Put_Line (Message =>
"Add_Remote_Imports (To_View" &
Qt (Naming.Get_Full_Name (To_View)) & ")",
Kind => Profile.Sharp_Msg);
while not Naming.Done (Imports) loop
Log.Put_Line (Message => ". Imported_View => " &
Naming.Source_Name (Imports),
Kind => Profile.Sharp_Msg);
Naming.Next (Imports);
end loop;
Naming.Reset (Imported_Views);
end if;
-- Make sure that To_View's remote library is imported by each of its
-- referencers.
Refresh_Referencers (To_View => To_View,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
Log.Put_Line (Ss.Message (Status), Profile.Negative_Msg);
Ss.Initialize (Status);
end if;
-- Now set up a remote link from To_View (and each of its referencers)
-- to each Imported_View (and each of its imports).
while not Naming.Done (Imported_Views) loop
Naming.Get_Object (Iter => Imported_Views,
The_Object => Import_Object,
Status => Error_Status);
if Error_Status /= Directory.Successful then
Set_Status
("Can't get object for " &
Naming.Source_Name (Imported_Views) & ". Error Status = " &
Directory.Error_Status'Image (Error_Status),
Status);
return;
end if;
if Trace_Command then
Log.Put_Line (". Imported_View => " &
Naming.Get_Full_Name (Import_Object),
Profile.Sharp_Msg);
end if;
-- Add a link on the remote Sparc from To_View (and each of its
-- referencers) to the imported view.
Add_Remote_Import (Imported_View => Import_Object,
To_View => To_View,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
Log.Put_Line (Ss.Message (Status), Profile.Negative_Msg);
Ss.Initialize (Status);
end if;
-- Now get the view's import closure, and add the remote
-- directories for all of the views in the closure to To_View's
-- (and each of its referencers) remote import list.
declare
Import : Directory.Object;
Import_Closure : constant View_Support.Unit_List :=
View_Support.Get_Imports (For_View => Import_Object,
Closure => True);
begin
if Ss.Error (Import_Closure.Condition) then
Log.Put_Line (Ss.Message (Import_Closure.Condition),
Profile.Negative_Msg);
Set_Status ("Can't get import closure for view " &
Naming.Get_Full_Name (Import_Object), Status);
return;
end if;
for Index in 1 .. Import_Closure.Size loop
Import := Import_Closure.Data (Index);
if Trace_Command then
Log.Put_Line (". Import_Closure (" &
Integer'Image (Index) & ", " &
Naming.Get_Full_Name (Import_Object) &
") => " & Naming.Get_Full_Name (Import),
Profile.At_Msg);
end if;
if Import /= To_View and then Import /= Import_Object then
Add_Remote_Import
(Imported_View => Import,
To_View => To_View,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
Log.Put_Line (Ss.Message (Status),
Profile.Negative_Msg);
Ss.Initialize (Status);
end if;
end if;
end loop;
end;
Naming.Next (Imported_Views);
end loop;
exception
when others =>
Unhandled_Exception (Status, "Add_Remote_Imports");
end Add_Remote_Imports;
procedure Remove_Remote_Import
(View_To_Remove : Directory.Object;
From_View : Directory.Object;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean) is
Imported_View : constant String :=
Naming.Get_Full_Name (View_To_Remove);
Imported_Result : constant Li.String_Result :=
Li.Remote_Directory (View => Imported_View);
Remote_Import_Directory : constant String := Imported_Result.Result;
Dir_Exists : Boolean;
From_View_Name : constant String := Naming.Get_Full_Name (From_View);
Directory_Result : constant Li.String_Result :=
Li.Remote_Directory (View => From_View_Name);
Remote_Directory : constant String := Directory_Result.Result;
Remove_Import_Cmd : constant String := "a.path -L ";
Remove_Import_Command : constant String :=
Remove_Import_Cmd & Remote_Directory &
" -r " & Remote_Import_Directory;
begin
if Trace_Command then
Log.Put_Line (Message => "Remove_Remote_Import (View_To_Remove" &
Qt (Imported_View) & ", From_View" &
Qt (From_View_Name) & ")",
Kind => Profile.Sharp_Msg);
end if;
if Ss.Error (Imported_Result.Condition) then
if Trace_Command then
Log.Put_Line (Ss.Message (Imported_Result.Condition),
Profile.Negative_Msg);
end if;
Set_Status ("Can't get remote directory name for imported view " &
Imported_View, Status);
return;
elsif Ss.Error (Directory_Result.Condition) then
if Trace_Command then
Log.Put_Line (Ss.Message (Directory_Result.Condition),
Profile.Negative_Msg);
end if;
Set_Status
("Can't get remote directory name for view " & From_View_Name,
Status);
return;
end if;
if Remote_Directory = "" then
Log.Put_Line (Message => "Remote directory name for view " &
From_View_Name & " is null",
Kind => Profile.Warning_Msg);
Set_Status ("Insufficient remote library information",
Status, Ss.Problem);
return;
elsif Remote_Import_Directory = "" then
Log.Put_Line (Message =>
"Remote directory name for imported view " &
Imported_View & " is null",
Kind => Profile.Warning_Msg);
Set_Status ("Insufficient remote library information",
Status, Ss.Problem);
return;
end if;
-- See if the Remote_Directory exists.
Rci.File_Exists (The_File => Remote_Directory,
Remote_Connection => Remote_Connection,
Status => Status,
Exists => Dir_Exists,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Status), Profile.Negative_Msg);
end if;
Set_Status
("Can't tell whether remote directory """ &
Remote_Directory & """ exists, so can't remove its import",
Status);
return;
end if;
if not Dir_Exists then
Log.Put_Line ("Remote directory """ & Remote_Directory &
""" doesn't exist for view " & From_View_Name &
", so we can't remove its import",
Profile.Warning_Msg);
return;
end if;
if Trace_Command then
Log.Put_Line ("Remove_Import_Command" & Qt (Remove_Import_Command) &
", View_To_Remove" & Qt (Imported_View),
Profile.At_Msg);
end if;
Rci.Execute_Command (Command_Line => Remove_Import_Command,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Status), Profile.Negative_Msg);
end if;
Set_Status ("Can't remove remote import " & Imported_View &
" from view " & From_View_Name, Status);
else
Log.Put_Line ("Removed remote library " & Remote_Import_Directory &
" as an import into " & Remote_Directory,
Profile.Positive_Msg);
end if;
end Remove_Remote_Import;
procedure Remove_Unused_Import
(View_To_Remove : Directory.Object;
From_View : Directory.Object;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Ss.Condition;
Trace_Command : Boolean) is
Importing_Closure : constant View_Support.Unit_List :=
View_Support.Get_Imports (From_View, True);
begin
if Ss.Error (Importing_Closure.Condition) then
Log.Put_Line (Ss.Message (Importing_Closure.Condition),
Profile.Negative_Msg);
Set_Status ("Can't get import closure for view " &
Naming.Get_Full_Name (From_View), Status);
return;
end if;
if not View_Support.Is_Member (View_To_Remove, Importing_Closure) then
Remove_Remote_Import (View_To_Remove => View_To_Remove,
From_View => From_View,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
end if;
end Remove_Unused_Import;
procedure Remove_All_Remote_Imports
(View_To_Remove : Directory.Object;
From_View : Directory.Object;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean) is
Import_Name : constant String := Naming.Get_Full_Name (View_To_Remove);
Referencer : Directory.Object;
Referencers : constant View_Support.Unit_List :=
View_Support.Get_Referencers (From_View, True);
begin
if Trace_Command then
Log.Put_Line (Message =>
"Remove_All_Remote_Imports (View_To_Remove" &
Qt (Import_Name) & ", From_View" &
Qt (Naming.Get_Full_Name (From_View)) & ")",
Kind => Profile.Sharp_Msg);
end if;
if Ss.Error (Referencers.Condition) then
if Trace_Command then
Log.Put_Line (Ss.Message (Referencers.Condition),
Profile.Negative_Msg);
end if;
Set_Status ("Can't get referencers for view " &
Naming.Get_Full_Name (From_View), Status);
return;
end if;
Remove_Unused_Import (View_To_Remove, From_View,
Remote_Connection, Status, Trace_Command);
if Ss.Error (Status) then
Log.Put_Line (Ss.Message (Status), Profile.Warning_Msg);
Log.Put_Line ("Remote library for " & Import_Name &
" isn't on search list for " &
Naming.Get_Full_Name (From_View),
Profile.Warning_Msg);
Ss.Initialize (Status);
end if;
-- Now remove all of the specified view's imports as remote imports
-- of From_View (unless they are required by another of From_View's
-- imports).
for Index in 1 .. Referencers.Size loop
Referencer := Referencers.Data (Index);
if Trace_Command then
Log.Put_Line (". Referencers (" & Integer'Image (Index) &
", " & Naming.Get_Full_Name (From_View) &
") => " & Naming.Get_Full_Name (Referencer),
Profile.At_Msg);
end if;
if Referencer /= View_To_Remove and then
Referencer /= From_View then
Remove_Unused_Import (View_To_Remove, Referencer,
Remote_Connection, Status, Trace_Command);
if Ss.Error (Status) then
Log.Put_Line (Ss.Message (Status), Profile.Warning_Msg);
Log.Put_Line ("Remote library for " & Import_Name &
" isn't on search list for " &
Naming.Get_Full_Name (Referencer),
Profile.Warning_Msg);
Ss.Initialize (Status);
end if;
end if;
end loop;
end Remove_All_Remote_Imports;
procedure Remove_Remote_Imports
(View_To_Remove : Directory.Object;
From_View : Directory.Object;
Remote_Connection : Remote_Command_Interface.Context;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean) is
Imported_View : constant String :=
Naming.Get_Full_Name (View_To_Remove);
Import : Directory.Object;
Imported_Closure : constant View_Support.Unit_List :=
View_Support.Get_Imports (For_View => View_To_Remove,
Closure => True);
begin
if Trace_Command then
Log.Put_Line ("Remove_Remote_Imports (View_To_Remove" &
Qt (Imported_View) & ", From_View" &
Qt (Naming.Get_Full_Name (From_View)) & ")",
Profile.Sharp_Msg);
end if;
if Ss.Error (Imported_Closure.Condition) then
Log.Put_Line (Ss.Message (Imported_Closure.Condition),
Profile.Negative_Msg);
Set_Status
("Can't get import closure for view " & Imported_View, Status);
return;
end if;
-- Remove the specified view as a remote import of From_View.
Remove_Remote_Import (View_To_Remove => View_To_Remove,
From_View => From_View,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
Log.Put_Line (Ss.Message (Status), Profile.Negative_Msg);
Set_Status
("Can't remove remote import for " & Imported_View &
" from remote import for " & Naming.Get_Full_Name (From_View),
Status);
return;
end if;
-- Now remove all of the specified view's imports as remote imports of
-- From_View and each of its referencers (unless they are required by
-- another of From_View's imports).
for Index in 1 .. Imported_Closure.Size loop
Import := Imported_Closure.Data (Index);
if Trace_Command then
Log.Put_Line (". Imported_Closure (" & Integer'Image (Index) &
") => " & Naming.Get_Full_Name (Import),
Profile.At_Msg);
end if;
if Import /= From_View and then Import /= View_To_Remove then
Remove_All_Remote_Imports
(View_To_Remove => Import,
From_View => From_View,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
Log.Put_Line (Ss.Message (Status), Profile.Negative_Msg);
Ss.Initialize (Status);
end if;
end if;
end loop;
exception
when others =>
Unhandled_Exception (Status, "Remove_Remote_Imports");
end Remove_Remote_Imports;
procedure Create_Remote_Directory (Remote_Directory : String;
Remote_Machine : String;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean := False) is
Remote_Connection : Rci.Context;
Local_Status : Ss.Condition;
Dir_Exists : Boolean := False;
Fil_Exists : Boolean := False;
Directory_Separator : constant String := "/";
Remote_Ada_Library : constant String := Remote_Directory & "/ada.lib";
Create_Dir_Command : constant String := "mkdir -p " & Remote_Directory;
Create_Ada_Lib_Command : constant String := "a.mklib -f ";
function Remote_Parent_Library_Name return String is
-- This routine reads a switch named Remote_Parent_Library
-- in the current view (ie. <view>.state.compiler_switches).
-- If the value is set, the value is
-- used as the parent library parameter for a.mklib. If the
-- value is null, the default target is used. This
-- instantiation has defined that to be the MC68881 library.
--
View_Path_Name : constant String :=
Directory_Tools.Naming.Full_Name ("<view>");
Remote_Parent_Library_Option : constant String :=
"M68K_Sunos_Vdx_Remote_Parent_Library";
Default_Remote_Parent_Library : constant String := " -t MC68881 ";
-- The VADS library for Floating Point Coprocessor Support.
Object : Directory.Object;
Name_Status : Directory.Naming.Name_Status;
begin
Object := Get_View (View_Path_Name);
declare
Remote_Parent_Lib : constant String :=
Rcf_Switch_Implementation.Value
(Name => Remote_Parent_Library_Option,
Switch_File => Object);
begin
if Remote_Parent_Lib = "" then
Log.Put_Line
(Message =>
"The option " & Remote_Parent_Library_Option &
" is not set for this view. As a result, the remote_library will be " &
"created utilizing the default parent library " &
Default_Remote_Parent_Library,
Kind => Profile.Warning_Msg,
Response => Profile.Get);
Log.Put_Line
(Message =>
"If this action is inappropriate, create the switch file and " &
"modify the Rcf." & Remote_Parent_Library_Option &
" switch to the proper value.",
Kind => Profile.Warning_Msg,
Response => Profile.Get);
return Default_Remote_Parent_Library & Remote_Directory;
else
Rci.File_Exists (The_File => Remote_Parent_Lib,
Remote_Connection => Remote_Connection,
Status => Status,
Exists => Fil_Exists,
Trace_Command => False);
if not Fil_Exists then
Log.Put_Line
("Can't tell whether Remote Parent library """ &
Remote_Parent_Lib & """ exists on machine """ &
Remote_Machine & """", Profile.Negative_Msg);
Rci.Release (Remote_Connection => Remote_Connection,
Status => Local_Status,
Trace_Command => Trace_Command);
return "";
end if;
Log.Put_Line (Message =>
"Using " & Remote_Parent_Lib &
" as the remote parent library.",
Kind => Profile.Note_Msg,
Response => Profile.Get);
return Remote_Directory & " " & Remote_Parent_Lib;
end if;
end;
end Remote_Parent_Library_Name;
begin
if Trace_Command then
Log.Put_Line (Message =>
"Create_Remote_Directory (Remote_Directory" &
Qt (Remote_Directory) & ", Remote_Machine" &
Qt (Remote_Machine) & ")",
Kind => Profile.Sharp_Msg);
end if;
Log.Put_Line (Message =>
"Creating remote directory" & Qt (Remote_Directory),
Kind => Profile.Debug_Msg);
if Su.Locate (Directory_Separator, Remote_Directory) /= 1 then
Set_Status ("Remote_Directory string must begin with a """ &
Directory_Separator & """ character", Status);
return;
end if;
Rci.Acquire (Remote_Connection => Remote_Connection,
Status => Status,
Target_Key => Target_Key,
Remote_Machine => Remote_Machine,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Status), Profile.Negative_Msg);
end if;
Set_Status
("Can't acquire connection to " & Remote_Machine, Status);
else
begin
-- See if the Ada library already exists in the remote
-- directory.
Rci.File_Exists (The_File => Remote_Ada_Library,
Remote_Connection => Remote_Connection,
Status => Status,
Exists => Fil_Exists,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Status),
Profile.Negative_Msg);
end if;
Set_Status ("Can't tell whether Ada library """ &
Remote_Ada_Library & """ exists on machine """ &
Remote_Machine & """", Status);
Rci.Release (Remote_Connection => Remote_Connection,
Status => Local_Status,
Trace_Command => Trace_Command);
return;
end if;
if Fil_Exists then
Log.Put_Line ("An Ada library already exists " &
"in remote directory """ &
Remote_Directory & """", Profile.Warning_Msg);
Rci.Release (Remote_Connection => Remote_Connection,
Status => Local_Status,
Trace_Command => Trace_Command);
return;
end if;
-- The Ada library doesn't exist, so we will need to create it.
-- Does the remote directory exist?
Rci.File_Exists (The_File => Remote_Directory,
Remote_Connection => Remote_Connection,
Status => Status,
Exists => Dir_Exists,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Status),
Profile.Negative_Msg);
end if;
Set_Status
("Can't tell whether directory """ & Remote_Directory &
""" exists on machine """ & Remote_Machine & """",
Status);
Rci.Release (Remote_Connection => Remote_Connection,
Status => Local_Status,
Trace_Command => Trace_Command);
return;
end if;
if Dir_Exists then
-- The directory exists, but it is not an Ada library. We
-- will create an Ada library within it.
Log.Put_Line (Message => "Directory """ & Remote_Directory &
""" already exists",
Kind => Profile.Warning_Msg);
Log.Put_Line (Message => "Using an existing directory",
Kind => Profile.Note_Msg);
else
-- The directory doesn't exist, so we will create it and
-- then make it into an Ada library.
Log.Put_Line (Message =>
"Creating the new remote directory """ &
Remote_Directory & """",
Kind => Profile.Note_Msg);
if Trace_Command then
Log.Put_Line ("Create_Dir_Command" &
Qt (Create_Dir_Command), Profile.At_Msg);
end if;
Rci.Execute_Command (Command_Line => Create_Dir_Command,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Status),
Profile.Negative_Msg);
end if;
Set_Status ("Can't create remote directory """ &
Remote_Directory & """", Status);
Rci.Release (Remote_Connection => Remote_Connection,
Status => Local_Status,
Trace_Command => Trace_Command);
return;
end if;
end if;
if Trace_Command then
Log.Put_Line ("Create_Ada_Lib_Command" &
Qt (Create_Ada_Lib_Command), Profile.At_Msg);
end if;
Rci.Execute_Command
(Command_Line => Create_Ada_Lib_Command & " " &
Remote_Parent_Library_Name,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Status),
Profile.Negative_Msg);
end if;
Set_Status
("Can't create an Ada library in remote directory """ &
Remote_Directory & """", Status);
else
Log.Put_Line ("A remote Ada library has been " &
"successfully created in " & Remote_Directory,
Profile.Positive_Msg);
end if;
exception
when others =>
Rci.Release (Remote_Connection => Remote_Connection,
Status => Local_Status,
Trace_Command => Trace_Command);
raise;
end;
end if;
Rci.Release (Remote_Connection => Remote_Connection,
Status => Local_Status,
Trace_Command => Trace_Command);
exception
when others =>
Unhandled_Exception (Status, "Create_Remote_Directory");
end Create_Remote_Directory;
procedure Destroy_Remote_Library (For_View : Directory.Object;
Remote_Directory : String;
Remote_Machine : String;
Status : in out Simple_Status.Condition;
Trace_Command : Boolean := False) is
Remote_Connection : Rci.Context;
Dir_Exists : Boolean := True;
Local_Status : Ss.Condition;
Remote_Ada_Library : constant String := Remote_Directory & "/ada.lib";
Unprotect_Library_Command : constant String :=
"chmod -R 777 " & Remote_Directory;
Remove_Ada_Library_Command : constant String :=
"a.rmlib -f " & Remote_Directory;
Destroy_Files_Command : constant String :=
"rm -f " & Remote_Directory & "/*";
Destroy_Options_File_Command : constant String :=
"rm -f " & Remote_Directory & "/.options*";
Remove_Directory_Command : constant String :=
"rmdir " & Remote_Directory;
begin
if Trace_Command then
Log.Put_Line
(Message => "Destroy_Remote_Library (Remote_Directory" &
Qt (Remote_Directory) &
", Remote_Machine" & Qt (Remote_Machine) & ")",
Kind => Profile.Sharp_Msg);
end if;
Log.Put_Line (Message => "Destroying Ada library in remote directory " &
Remote_Directory,
Kind => Profile.Debug_Msg);
Rci.Acquire (Remote_Connection => Remote_Connection,
Status => Status,
Target_Key => Target_Key,
Remote_Machine => Remote_Machine,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Status), Profile.Negative_Msg);
end if;
Set_Status
("Can't acquire connection to " & Remote_Machine, Status);
else
begin
Rci.File_Exists (The_File => Remote_Ada_Library,
Remote_Connection => Remote_Connection,
Status => Status,
Exists => Dir_Exists,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Status),
Profile.Negative_Msg);
end if;
Set_Status
("Can't tell whether Ada library " &
"exists in directory """ & Remote_Directory &
""" on machine """ & Remote_Machine & """", Status);
Rci.Release (Remote_Connection => Remote_Connection,
Status => Local_Status,
Trace_Command => Trace_Command);
return;
end if;
if not Dir_Exists then
Log.Put_Line (Message =>
"There is no remote Ada library " &
"in directory """ & Remote_Directory &
""" on machine " & Remote_Machine,
Kind => Profile.Negative_Msg);
Set_Status ("Can't destroy remote library",
Status, Ss.Problem);
Rci.Release (Remote_Connection => Remote_Connection,
Status => Local_Status,
Trace_Command => Trace_Command);
return;
end if;
-- Remove Remote_Directory as an import from each of For_View's
-- referencers.
declare
Importer : Directory.Object;
Referencers : constant View_Support.Unit_List :=
View_Support.Get_Referencers (For_View, True);
begin
if Ss.Error (Referencers.Condition) then
if Trace_Command then
Log.Put_Line (Ss.Message (Referencers.Condition),
Profile.Negative_Msg);
end if;
Set_Status ("Can't get referencers for view " &
Naming.Get_Full_Name (For_View), Status);
Rci.Release (Remote_Connection => Remote_Connection,
Status => Local_Status,
Trace_Command => Trace_Command);
return;
end if;
for Index in 1 .. Referencers.Size loop
Importer := Referencers.Data (Index);
if Trace_Command then
Log.Put_Line
(". Referencers (" & Integer'Image (Index) &
", " & Naming.Get_Full_Name (For_View) &
") => " & Naming.Get_Full_Name (Importer),
Profile.At_Msg);
end if;
if Importer /= For_View then
-- Remove For_View as a remote import of Importer.
-- Also remove as imports of Importer the views
-- that are imported by For_View which are not
-- otherwise needed by Importer. Remove the same
-- views, if they are not still needed, from each
-- referencer of Importer.
Remove_Remote_Imports
(View_To_Remove => For_View,
From_View => Importer,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
Log.Put_Line (Ss.Message (Status),
Profile.Warning_Msg);
Log.Put_Line ("Can't remove remote library " &
Remote_Directory &
" as an import of " &
Naming.Get_Full_Name (Importer),
Profile.Warning_Msg);
Ss.Initialize (Status);
end if;
end if;
end loop;
end;
if Trace_Command then
Log.Put_Line ("Executing command" &
Qt (Unprotect_Library_Command),
Profile.At_Msg);
end if;
Rci.Execute_Command (Command_Line => Unprotect_Library_Command,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Status),
Profile.Negative_Msg);
end if;
Set_Status ("Can't unprotect " & Remote_Directory, Status);
else
if Trace_Command then
Log.Put_Line ("Executing command" &
Qt (Remove_Ada_Library_Command),
Profile.At_Msg);
end if;
Rci.Execute_Command
(Command_Line => Remove_Ada_Library_Command,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Status),
Profile.Negative_Msg);
end if;
Set_Status ("Can't destroy the remote Ada library " &
Remote_Directory, Status);
else
if Trace_Command then
Log.Put_Line ("Executing command" &
Qt (Destroy_Files_Command),
Profile.At_Msg);
end if;
Rci.Execute_Command
(Command_Line => Destroy_Files_Command,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Status),
Profile.Warning_Msg);
end if;
Set_Status ("Can't destroy the files in " &
"remote directory " & Remote_Directory,
Status, Ss.Warning);
else
if Trace_Command then
Log.Put_Line ("Executing command" &
Qt (Destroy_Options_File_Command),
Profile.At_Msg);
end if;
Rci.Execute_Command
(Command_Line => Destroy_Options_File_Command,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Status),
Profile.Warning_Msg);
end if;
Set_Status
("Can't destroy the '.options' file in " &
"remote directory " & Remote_Directory,
Status, Ss.Warning);
else
if Trace_Command then
Log.Put_Line ("Executing command" &
Qt (Remove_Directory_Command),
Profile.At_Msg);
end if;
Rci.Execute_Command
(Command_Line => Remove_Directory_Command,
Remote_Connection => Remote_Connection,
Status => Status,
Trace_Command => Trace_Command);
if Ss.Error (Status) then
if Trace_Command then
Log.Put_Line (Ss.Message (Status),
Profile.Warning_Msg);
end if;
Set_Status
("Can't destroy remote directory " &
Remote_Directory, Status, Ss.Warning);
else
Log.Put_Line ("Remote directory " &
Remote_Directory &
" has been destroyed",
Profile.Positive_Msg);
end if;
end if;
end if;
end if;
end if;
exception
when others =>
Rci.Release (Remote_Connection => Remote_Connection,
Status => Local_Status,
Trace_Command => Trace_Command);
raise;
end;
end if;
Rci.Release (Remote_Connection => Remote_Connection,
Status => Local_Status,
Trace_Command => Trace_Command);
exception
when others =>
Unhandled_Exception (Status, "Destroy_Remote_Library");
end Destroy_Remote_Library;
end Extensions_Support;