|
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 - downloadIndex: ┃ B T ┃
Length: 30744 (0x7818)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─ ⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦059497ac5⟧
└─⟦this⟧
with Text_Io;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Basic3;
use Xlbt_Basic3;
with Xlbt_Display3;
use Xlbt_Display3;
with Xlbt_Proc_Var;
use Xlbt_Proc_Var;
with Xlbit_Library4;
use Xlbit_Library4;
with Xlbip_String_Map_Generic;
with Xlbmt_Network_Types;
use Xlbmt_Network_Types;
with Xlbmt_Parameters;
use Xlbmt_Parameters;
with Xlbmp_Error_Log;
use Xlbmp_Error_Log;
package body Xlbit_Library3 is
------------------------------------------------------------------------------
-- X Library Internal State
--
-- Xlbit_Library3 - Library State - No packages have any non-constant state
-- other than this set of packages.
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
-- Copyright 1985 - 1989 by the Massachusetts Institute of Technology
--
-- All Rights Reserved.
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright notice(s) appear in all copies and that
-- both that copyright notice(s) and this permission notice appear in
-- supporting documentation, and that the names of MIT or Rational not be
-- used in advertising or publicity pertaining to distribution of the software
-- without specific, written prior permission.
--
-- MIT and Rational disclaim all warranties with regard to this software,
-- including all implied warranties of merchantability and fitness, in no
-- event shall MIT or Rational be liable for any special, indirect or
-- consequential damages or any damages whatsoever resulting from loss of use,
-- data or profits, whether in an action of contract, negligence or other
-- tortious action, arising out of or in connection with the use or performance
-- of this software.
------------------------------------------------------------------------------
-- *****************************************************************************
-- * Date - /Name/ Comment
-- *
-- * 6-NOV-90 - /GEB/ Implement the new multitasking protection scheme for
-- * - library state.
-- *****************************************************************************
--/ if Multitask_Locking then
-- Multi-tasking capability *has* been turned on.
--/ else
--// -- Multi-tasking capability has *not* been turned on.
--/ end if;
--\f
------------------------------------------------------------------------------
-- Protected Global Library State
------------------------------------------------------------------------------
type X_Library_State is
record
Authorization_Name : U_Char_List := None_U_Char_List;
Authorization_Data : U_Char_List := None_U_Char_List;
----Data used when connecting to a server. Used to authorize
-- access. Values of None mean that we use the default
-- mechanisms and default data. Typically this is the "xhost"
-- method.
Debug : Boolean := False;
----Turn on special debug/synchronization code.
Report_Error : X_Procedure_Variable := None_X_Procedure_Variable;
----X_Report_Error.Pv
----Report_Error is the lowest level error reporter, and is
-- called by all default higher level reporters. This should
-- not be assumed to be a fatal condition.
Error : X_Procedure_Variable := None_X_Procedure_Variable;
----X_Error_Function.Pv
----Error will be called whenever an error event is received.
-- This is not assumed to be a fatal condition, i.e., it is
-- acceptable for this procedure to return. However, Error
-- should NOT perform any operations (directly or indirectly)
-- on the DISPLAY.
Display_Num_Counter : X_Display_Number := 0;
----Used to give displays a unique number that can be
-- used with the RM as "contexts" for display-specific
-- values that aren't entered into a display-specific database.
Head_Of_Display_List : X_Display := null;
----There are all of the open displays in this X_Library instance.
Io_Error : X_Procedure_Variable := None_X_Procedure_Variable;
----X_Io_Error_Function.Pv
----IO_Error will be called if any sort of network error occurs.
-- This is assumed to be a fatal condition, i.e., IO_Error should
-- not return. It should abort the program or raise an exception.
Quark_Map : X_Rm_Quark_Map.Map;
----Map of all known Quarks.
Next_Quark : X_Rm_Quark := (Id => 1);
----Next available quark number
Resource_Quarks : X_Rm_Quark_Bit_List := None_X_Rm_Quark_Bit_List;
----Used by the RM to optimize resource lookup.
-- Rm_Conversion_Error : X_Procedure_Variable := None_X_Procedure_Variable;
-- ----X_Rm_Converter_Error.Pv
-- ----Rm_Conversion_Error is called whenever a conversion routine
-- -- fails. Presumably the From value is invalid or does not
-- -- map into the To value.
--
-- Rm_No_Converter : X_Procedure_Variable := None_X_Procedure_Variable;
-- ----X_Rm_Converter_Error.Pv
-- ----Rm_No_Converter is called whenever we need to make a conversion
-- -- but there is no routine registered to perform it.
--
-- Rm_Converter_Table : X_Rm_Converter_List := null;
-- ----Cache of all registered RM type conversion routines.
end record;
X : X_Library_State;
--\f
--/ if Multitask_Locking then
task body X_Lib is
Seized_Display_List : Boolean := False;
Seized_Quark_Map : Boolean := False;
Seized_Resource_Quarks : Boolean := False;
begin
loop
select
--/ else
--// package body X_Lib is
--/ end if;
--\f
--/ if Multitask_Locking then
accept Get_Authorization
(Authorization_Name : out U_Char_List;
Authorization_Data : out U_Char_List) do
--/ else
--// procedure Get_Authorization (Authorization_Name : out U_Char_List;
--// Authorization_Data : out U_Char_List) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- Authorization_Name - Specifies/Receives the authorization name to use
-- Authorization_Data - Specifies/Receives the authorization data to use
--
-- Gets/Sets the data used when connecting to a server. It is used to authorize
-- access to the server. Values of None_U_Char_List mean that we use the
-- default mechanisms and default data. Typically this is the "xhost"
-- method.
------------------------------------------------------------------------------
Authorization_Name := X.Authorization_Name;
Authorization_Data := X.Authorization_Data;
end Get_Authorization;
--\f
--/ if Multitask_Locking then
or
accept Set_Authorization (Authorization_Name : U_Char_List;
Authorization_Data : U_Char_List) do
--/ else
--// procedure Set_Authorization (Authorization_Name : U_Char_List;
--// Authorization_Data : U_Char_List) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- Authorization_Name - Specifies/Receives the authorization name to use
-- Authorization_Data - Specifies/Receives the authorization data to use
--
-- Gets/Sets the data used when connecting to a server. It is used to authorize
-- access to the server. Values of None_U_Char_List mean that we use the
-- default mechanisms and default data. Typically this is the "xhost"
-- method.
------------------------------------------------------------------------------
X.Authorization_Name := Authorization_Name;
X.Authorization_Data := Authorization_Data;
end Set_Authorization;
--\f
--/ if Multitask_Locking then
or
accept Get_Debug (On_Off : out Boolean) do
--/ else
--// procedure get_Debug (On_Off : out Boolean) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- On_Off - Specifies TRUE to turn synchronization on.
--
-- Turn on/off special debug/synchronization code. When a new display is
-- opened, it will have synchronization turned on by default if this flag has
-- been previously set to true.
------------------------------------------------------------------------------
On_Off := X.Debug;
end Get_Debug;
--\f
--/ if Multitask_Locking then
or
accept Set_Debug (On_Off : Boolean) do
--/ else
--// procedure Set_Debug (On_Off : Boolean) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- On_Off - Specifies TRUE to turn synchronization on.
--
-- Turn on/off special debug/synchronization code. When a new display is
-- opened, it will have synchronization turned on by default if this flag has
-- been previously set to true.
------------------------------------------------------------------------------
X.Debug := On_Off;
end Set_Debug;
--\f
--/ if Multitask_Locking then
or
accept Add_Display (Display : X_Display) do
--/ else
--// procedure Add_Display (Display : X_Display) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- Display - Specifies the display to affect
--
-- Adds a new display to the library's list of open displays or else removes
-- a display from that list. This is used to give displays a unique number
-- that can be used with the RM as "contexts" for display-specific
-- values that aren't entered into a display-specific database.
------------------------------------------------------------------------------
Display.Next := X.Head_Of_Display_List;
X.Head_Of_Display_List := Display;
Display.Display_Num := X.Display_Num_Counter;
X.Display_Num_Counter := X.Display_Num_Counter + 1;
if X.Display_Num_Counter = X_Display_Number'Last then
----2**32 sequential display connections in one library? Wow.
-- Don't allow 'Last as a valid display number value; the RM
-- uses that for a don't-care value.
X.Display_Num_Counter := 0;
end if;
end Add_Display;
--\f
--/ if Multitask_Locking then
or
accept Remove_Display (Display : X_Display) do
--/ else
--// procedure Remove_Display (Display : X_Display) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- Display - Specifies the display to affect
--
-- Adds a new display to the library's list of open displays or else removes
-- a display from that list. This is used to give displays a unique number
-- that can be used with the RM as "contexts" for display-specific
-- values that aren't entered into a display-specific database.
------------------------------------------------------------------------------
declare
Dp : X_Display;
Cp : X_Display;
begin
if X.Head_Of_Display_List = Display then
X.Head_Of_Display_List := Display.Next;
else
Dp := X.Head_Of_Display_List;
Cp := Dp.Next;
while Cp /= null loop
if Cp = Display then
Dp.Next := Cp.Next;
exit;
end if;
Dp := Cp;
Cp := Cp.Next;
end loop;
end if;
end;
end Remove_Display;
--\f
--/ if Multitask_Locking then
or
accept Get_Report_Error (Proc : out X_Procedure_Variable) do
--/ else
--// procedure Get_Report_Error (Proc : out X_Procedure_Variable) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- Proc - Specifies/Receives the procedure to use; a value of
-- None_X_Procedure_Variable restores the library default
-- value for this procedure.
--
-- Actaul type of Proc is X_Report_Error.Pv.
--
-- Report_Error is the lowest level error reporter, and is
-- called by all of the default higher level reporters. It is used to format
-- error messages and to send them to the appropriate file/device/terminal.
-- Messages should not be assumed to be fatal conditions.
------------------------------------------------------------------------------
if X.Report_Error /= None_X_Procedure_Variable then
Proc := X.Report_Error;
else
Proc := X_Lib_Default_X_Report_Error;
end if;
end Get_Report_Error;
--\f
--/ if Multitask_Locking then
or
accept Set_Report_Error (Proc : X_Procedure_Variable;
Old_Proc : out X_Procedure_Variable) do
--/ else
--// procedure Set_Report_Error (Proc : X_Procedure_Variable;
--// Old_Proc : out X_Procedure_Variable) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- Proc - Specifies/Receives the procedure to use; a value of
-- None_X_Procedure_Variable restores the library default
-- value for this procedure.
-- Old_Proc - Receives the previous procedure setting.
--
-- Actaul type of Proc is X_Report_Error.Pv.
--
-- Report_Error is the lowest level error reporter, and is
-- called by all of the default higher level reporters. It is used to format
-- error messages and to send them to the appropriate file/device/terminal.
-- Messages should not be assumed to be fatal conditions.
------------------------------------------------------------------------------
declare
Old :
X_Procedure_Variable; -- Prevent aliasing problems.
begin
Old := X.Report_Error;
X.Report_Error := Proc;
Old_Proc := Old;
end;
end Set_Report_Error;
--\f
--/ if Multitask_Locking then
or
accept Get_Error (Display : X_Display;
Proc : out X_Procedure_Variable) do
--/ else
--// procedure Get_Error (Display : X_Display;
--// Proc : out X_Procedure_Variable) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- Display - Specifies a display to use
-- Proc - Specifies/Receives the procedure to use; a value of
-- None_X_Procedure_Variable restores the library default
-- value for this procedure.
-- Old_Proc - Receives the previous procedure setting.
-- All_Displays - Specifies TRUE to set a global default
--
-- Actaul type of Proc is X_Error_Function.Pv.
--
-- The Error procedure will be called whenever an error event is received.
-- This is not assumed to be a fatal condition, i.e., it is acceptable for
-- this procedure to return. However, Error should NOT perform any operations
-- (directly or indirectly) on any X_Display.
--
-- All_Displays => True means that we are setting the global default value.
-- All_Displays => False means we are setting this display's default value.
------------------------------------------------------------------------------
if Display.Error /= None_X_Procedure_Variable then
Proc := Display.Error;
elsif X.Error /= None_X_Procedure_Variable then
Proc := X.Error;
else
Proc := X_Lib_Default_X_Error_Function;
end if;
end Get_Error;
--\f
--/ if Multitask_Locking then
or
accept Set_Error (Display : X_Display;
Proc : X_Procedure_Variable;
Old_Proc : out X_Procedure_Variable;
All_Displays : Boolean := True) do
--/ else
--// procedure Set_Error (Display : X_Display;
--// Proc : X_Procedure_Variable;
--// Old_Proc : out X_Procedure_Variable;
--// All_Displays : Boolean := True) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- Display - Specifies a display to use
-- Proc - Specifies/Receives the procedure to use; a value of
-- None_X_Procedure_Variable restores the library default
-- value for this procedure.
-- Old_Proc - Receives the previous procedure setting.
-- All_Displays - Specifies TRUE to set a global default
--
-- Actaul type of Proc is X_Error_Function.Pv.
--
-- The Error procedure will be called whenever an error event is received.
-- This is not assumed to be a fatal condition, i.e., it is acceptable for
-- this procedure to return. However, Error should NOT perform any operations
-- (directly or indirectly) on any X_Display.
--
-- All_Displays => True means that we are setting the global default value.
-- All_Displays => False means we are setting this display's default value.
------------------------------------------------------------------------------
declare
Old :
X_Procedure_Variable; -- Prevent aliasing problems.
begin
if All_Displays then
Old := X.Error;
X.Error := Proc;
Old_Proc := Old;
else
Old := Display.Error;
Display.Error := Proc;
Old_Proc := Old;
end if;
end;
end Set_Error;
--\f
--/ if Multitask_Locking then
or
accept Get_Io_Error (Display : X_Display;
Proc : out X_Procedure_Variable) do
--/ else
--// procedure Get_Io_Error (Display : X_Display;
--// Proc : out X_Procedure_Variable) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- Display - Specifies a display to use
-- Proc - Specifies/Receives the procedure to use; a value of
-- None_X_Procedure_Variable restores the library default
-- value for this procedure.
-- Old_Proc - Receives the previous procedure setting.
-- All_Displays - Specifies TRUE to set a global default
--
-- Actaul type of Proc is X_Io_Error_Function.Pv.
--
-- The IO_Error procedure will be called if any sort of network error occurs.
-- This is assumed to be a fatal condition, i.e., IO_Error should not return.
-- It should abort the program or raise an exception. In a multitasking
-- program it should presumably raise an exception.
--
-- All_Displays => True means that we are setting the global default value.
-- All_Displays => False means we are setting this display's default value.
------------------------------------------------------------------------------
if Display.Io_Error /= None_X_Procedure_Variable then
Proc := Display.Io_Error;
elsif X.Io_Error /= None_X_Procedure_Variable then
Proc := X.Io_Error;
else
Proc := X_Lib_Default_X_Io_Error_Function;
end if;
end Get_Io_Error;
--\f
--/ if Multitask_Locking then
or
accept Set_Io_Error (Display : X_Display;
Proc : X_Procedure_Variable;
Old_Proc : out X_Procedure_Variable;
All_Displays : Boolean := True) do
--/ else
--// procedure Set_Io_Error (Display : X_Display;
--// Proc : X_Procedure_Variable;
--// Old_Proc : out X_Procedure_Variable;
--// All_Displays : Boolean := True) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- Display - Specifies a display to use
-- Proc - Specifies/Receives the procedure to use; a value of
-- None_X_Procedure_Variable restores the library default
-- value for this procedure.
-- Old_Proc - Receives the previous procedure setting.
-- All_Displays - Specifies TRUE to set a global default
--
-- Actaul type of Proc is X_Io_Error_Function.Pv.
--
-- The IO_Error procedure will be called if any sort of network error occurs.
-- This is assumed to be a fatal condition, i.e., IO_Error should not return.
-- It should abort the program or raise an exception. In a multitasking
-- program it should presumably raise an exception.
--
-- All_Displays => True means that we are setting the global default value.
-- All_Displays => False means we are setting this display's default value.
------------------------------------------------------------------------------
declare
Old :
X_Procedure_Variable; -- Prevent aliasing problems.
begin
if All_Displays then
Old := X.Io_Error;
X.Io_Error := Proc;
Old_Proc := Old;
else
Old := Display.Io_Error;
Display.Io_Error := Proc;
Old_Proc := Old;
end if;
end;
end Set_Io_Error;
--\f
--/ if Multitask_Locking then
or
when not Seized_Display_List =>
accept Seize_Display_List (Display : out X_Display) do
Seized_Display_List := True;
--/ else
--// procedure Seize_Display_List (Display : out X_Display) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- Display - Receives the display list.
--
-- Called to Seize the list of all currently open displays. While this list
-- is Seized, no displays can be opened or closed. Be sure to Release it.
-- Do not modify the list in any way.
------------------------------------------------------------------------------
Display := X.Head_Of_Display_List;
end Seize_Display_List;
--\f
--/ if Multitask_Locking then
or
when Seized_Display_List =>
accept Release_Display_List do
Seized_Display_List := False;
--/ else
--// procedure Release_Display_List is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- Display - Receives the display list.
--
-- Called to Seize the list of all currently open displays. While this list
-- is Seized, no displays can be opened or closed. Be sure to Release it.
-- Do not modify the list in any way.
------------------------------------------------------------------------------
null;
end Release_Display_List;
--\f
--/ if Multitask_Locking then
or
when not Seized_Quark_Map =>
accept Seize_Quark_Map (Map : out X_Rm_Quark_Map.Map) do
Seized_Quark_Map := True;
--/ else
--// procedure Seize_Quark_Map (Map : out X_Rm_Quark_Map.Map) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- Map - Specifies/Receives the quark map for the library
--
-- Map of all known Quarks. All displays share the same set of quark values.
-- Seize the map, use it in some way, and then Release it. Whatever you
-- Release will become the new map for all displays.
------------------------------------------------------------------------------
Map := X.Quark_Map;
end Seize_Quark_Map;
--\f
--/ if Multitask_Locking then
or
when Seized_Quark_Map =>
accept Release_Quark_Map
(Map : in out X_Rm_Quark_Map.Map) do
Seized_Quark_Map := False;
--/ else
--// procedure Release_Quark_Map (Map : in out X_Rm_Quark_Map.Map) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- Map - Specifies/Receives the quark map for the library
--
-- Map of all known Quarks. All displays share the same set of quark values.
-- Seize the map, use it in some way, and then Release it. Whatever you
-- Release will become the new map for all displays.
------------------------------------------------------------------------------
X.Quark_Map := Map;
Map := X_Rm_Quark_Map.None_Map;
end Release_Quark_Map;
--\f
--/ if Multitask_Locking then
or
accept Get_Next_Quark (Quark : out X_Rm_Quark) do
--/ else
--// procedure Get_Next_Quark (Quark : out X_Rm_Quark) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- Quark - Specifies/Receives the new quark value
--
-- Used to generate new quark values. The Set interface is only for debugging
-- and library testing.
------------------------------------------------------------------------------
Quark := X.Next_Quark;
X.Next_Quark.Id := X.Next_Quark.Id + 1;
end Get_Next_Quark;
--\f
--/ if Multitask_Locking then
or
when not Seized_Quark_Map =>
accept Set_Next_Quark (Quark : X_Rm_Quark) do
--/ else
--// procedure Set_Next_Quark (Quark : X_Rm_Quark) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- Quark - Specifies/Receives the new quark value
--
-- Used to generate new quark values. The Set interface is only for debugging
-- and library testing.
------------------------------------------------------------------------------
X.Next_Quark := Quark;
end Set_Next_Quark;
--\f
--/ if Multitask_Locking then
or
when not Seized_Resource_Quarks =>
accept Seize_Resource_Quarks
(List : out X_Rm_Quark_Bit_List) do
Seized_Resource_Quarks := True;
--/ else
--// procedure Seize_Resource_Quarks (List : out X_Rm_Quark_Bit_List) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- List - Specifies/Receives the boolean array of known resource quarks
--
-- Used by the RM to optimize resource lookup. Seize the list, modify it,
-- then Release it so that others can use the modified/reallocated list.
------------------------------------------------------------------------------
List := X.Resource_Quarks;
end Seize_Resource_Quarks;
--\f
--/ if Multitask_Locking then
or
when Seized_Resource_Quarks =>
accept Release_Resource_Quarks
(List : in out X_Rm_Quark_Bit_List) do
Seized_Resource_Quarks := False;
--/ else
--// procedure Release_Resource_Quarks (List : in out X_Rm_Quark_Bit_List) is
--// begin
--/ end if;
------------------------------------------------------------------------------
-- List - Specifies/Receives the boolean array of known resource quarks
--
-- Used by the RM to optimize resource lookup. Seize the list, modify it,
-- then Release it so that others can use the modified/reallocated list.
------------------------------------------------------------------------------
X.Resource_Quarks := List;
List := None_X_Rm_Quark_Bit_List;
end Release_Resource_Quarks;
--\f
--/ if Multitask_Locking then
or
terminate;
end select;
--/ end if;
------------------------------------------------------------------------------
-- Loop and get the next rendezvous.
------------------------------------------------------------------------------
end loop;
end X_Lib;
--\f
end Xlbit_Library3;