|
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: 16011 (0x3e8b)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦059497ac5⟧
└─⟦this⟧
--/ if R1000 then
with Transport;
with Transport_Defs;
--/ end if;
with Unchecked_Deallocation;
with Xlbt_Exceptions;
use Xlbt_Exceptions;
package body Xlbmt_Network_Types is
------------------------------------------------------------------------------
-- X Library Machine Network Types
--
-- Xlbmt_Network_Types - Machine/Compiler dependent network interface types.
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
--
-- 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 name of Rational not be used in
-- advertising or publicity pertaining to distribution of the software
-- without specific, written prior permission.
--
-- Rational disclaims all warranties with regard to this software, including
-- all implied warranties of merchantability and fitness, in no event shall
-- 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.
------------------------------------------------------------------------------
--/ if Multitask_Locking then
procedure Heap_Free_X_Mutex is new Unchecked_Deallocation (X_Mutex_Rec,
X_Mutex);
--/ end if;
--\f
--/ if R1000 and not R1000_Xlib_Only then
task body Notify_Complete_Task is
------------------------------------------------------------------------------
-- Simple bistable flag with multitask interlocking. Only the Xt reader will
-- ever call Set_Not_Done or Wait_For_Done. Only Connection_Readers will
-- ever call Set_Done.
--
-- - when Xt wants to read from its display(s) it will call Read_Queue
-- on each one and will call Set_Not_Done when the first one comes
-- back with status Pending_Read_Wait
-- - when Xt has called Read_Queue on each display it will call Wait_For_Done
-- which will only rendezvous when some display has read something
-- - Connection_Readers attempt to do a read; when that fails they change
-- their state to Pending_Read_Wait and leave the rendezvous (Xt then
-- continues); the readers then wait forever for a read to complete;
-- when it completes they set their state to Pending_Read_Done and then
-- call Set_Done; this ordering guarantees that Xt doesn't have to call
-- Set_Not_Done before Read_Queue and that no read completion will get
-- lost if Xt does Set_Not_Done and *then* checks the state; Xt will
-- shortly call Wait_For_Done which would then complete.
------------------------------------------------------------------------------
Flag : Boolean := False;
begin
----Loop forever.
loop
----If the flag is not set then only calls to set/reset it are accepted.
select
accept Set_Not_Done do
Flag := False; -- Called to reset flag
end Set_Not_Done;
or
accept Set_Done do
Flag := True; -- Called to set flag
end Set_Done;
or
terminate;
end select;
----If the flag is set then all calls are allowed.
while Flag loop
select
accept Set_Not_Done do
Flag := False; -- Called to reset flag
end Set_Not_Done;
or
accept Set_Done do
Flag := True; -- Called to set flag
end Set_Done;
or
accept Wait_For_Done do
Flag := False; -- Called to wait for set flag
end Wait_For_Done; -- There is only one wait'er.
or
terminate;
end select;
end loop;
end loop;
end Notify_Complete_Task;
--/ end if;
--\f
--/ if R1000 and not R1000_Xlib_Only then
task body Connection_Reader is
------------------------------------------------------------------------------
-- Reader task for all Xlib connections. The Xlib will only call the
-- Maybe or the Must entries. The Xt calls the Queue entry when it would like
-- to read but doesn't want to wait if there is nothing ready. A Queue'd
-- read will exit the Select and then do a read that blocks until we get
-- something. It then uses the Notify_Task to tell Xt that it has done
-- something.
------------------------------------------------------------------------------
Our_Connection : Connection_Id;
Notify_Task : Notify_Complete;
Queue_Count : X_Raw_Data_Index := 0;
Queue_Buffer : X_Raw_Data_Array (1 .. 1);
Tmp_Count : X_Raw_Data_Index;
Tmp_Status : Status_Code;
begin
----Wait for our initialize call. We don't really exist until we get it.
select
accept Initialize (Connection : Connection_Id) do
Our_Connection := Connection;
Our_Connection.State := Pending_Read_None;
end Initialize;
or
terminate;
end select;
----Loop until we get aborted or until the program exits.
loop
while Notify_Task = None_Notify_Complete loop
------------------------------------------------------------------------------
-- Receive_Mabe entry - try a read; if it fails then just return
------------------------------------------------------------------------------
select
accept Receive_Maybe (Status : out Status_Code;
Data : in out X_Raw_Data_Array;
Count : out X_Raw_Data_Index) do
if Queue_Count > 0 then
Data (Data'First) := Queue_Buffer (1);
Queue_Count := 0;
Transport.Receive
(Connection => Our_Connection.Connection,
Status => Status,
Data => Data (Data'First + 1 .. Data'Last),
Count => Tmp_Count,
Max_Wait => 0.0);
Count := Tmp_Count + 1;
return;
else
Transport.Receive
(Connection => Our_Connection.Connection,
Status => Status,
Data => Data,
Count => Count,
Max_Wait => 0.0);
return;
end if;
end Receive_Maybe;
------------------------------------------------------------------------------
-- Receive_Queue entry - try to read; if that fails then queue a read
------------------------------------------------------------------------------
or
accept Receive_Queue (Status : out Status_Code;
Data : in out X_Raw_Data_Array;
Count : out X_Raw_Data_Index;
Notify : Notify_Complete) do
if Queue_Count > 0 then
Data (Data'First) := Queue_Buffer (1);
Queue_Count := 0;
Transport.Receive
(Connection => Our_Connection.Connection,
Status => Status,
Data => Data (Data'First + 1 .. Data'Last),
Count => Tmp_Count,
Max_Wait => 0.0);
Count := Tmp_Count + 1;
return;
else
Transport.Receive
(Connection => Our_Connection.Connection,
Status => Tmp_Status,
Data => Data,
Count => Tmp_Count,
Max_Wait => 0.0);
Status := Tmp_Status;
Count := Tmp_Count;
if Tmp_Count > 0 or else
(Tmp_Status /= Transport_Defs.Ok and then
Tmp_Status /= Transport_Defs.Timed_Out) then
return;
end if;
Notify_Task := Notify;
Our_Connection.State := Pending_Read_Wait;
end if;
end Receive_Queue;
------------------------------------------------------------------------------
-- Receive_Must entry - we do not return until we get what we came for
------------------------------------------------------------------------------
or
accept Receive_Must (Status : out Status_Code;
Data : in out X_Raw_Data_Array;
Count : out X_Raw_Data_Index) do
declare
Need_Count : constant X_Raw_Data_Index :=
Data'Length;
Total : X_Raw_Data_Index;
begin
Tmp_Status := Transport_Defs.Ok;
if Queue_Count > 0 then
Data (Data'First) := Queue_Buffer (1);
Queue_Count := 0;
Total := 1;
else
Total := 0;
end if;
----If we got all we asked for then return to the caller.
loop
if Total = Need_Count or else
Tmp_Status /= Transport_Defs.Ok then
Status := Tmp_Status;
Count := Total;
return;
end if;
----Receive what we can this time.
Transport.Receive
(Connection => Our_Connection.Connection,
Status => Tmp_Status,
Data => Data (Data'First + Total ..
Data'Last),
Count => Tmp_Count,
Max_Wait => Duration'Last);
Total := Total + Tmp_Count;
end loop;
end;
end Receive_Must;
------------------------------------------------------------------------------
-- Terminate if necessary.
------------------------------------------------------------------------------
or
terminate;
end select;
end loop;
----Do an initial receive. See if we get what we wanted without further
-- effort.
Transport.Receive (Connection => Our_Connection.Connection,
Status => Tmp_Status,
Data => Queue_Buffer,
Count => Queue_Count,
Max_Wait => Duration'Last);
----If we got it then return it all to the caller. Set our state first and
-- then call the notify task afterwards. Xt always checks the state first
-- and then does a rendezvous if it can't do anything else. (Saves a trifle
-- of time.)
Our_Connection.State := Pending_Read_Done;
Notify_Task.Set_Done;
if Tmp_Status /= Transport_Defs.Ok then
Queue_Count := 0;
end if;
Notify_Task := None_Notify_Complete;
end loop;
end Connection_Reader;
--/ end if;
--\f
--/ if Multitask_Locking then
task body X_Mutex_Rec is
------------------------------------------------------------------------------
-- Lock or Unlock the X_Library data structure.
------------------------------------------------------------------------------
begin
loop
----We start out unlocked; so accept any Lock entry.
select
accept Lock do
null;
end Lock;
or
accept Unlock do
----We aren't locked!?!?
raise X_Library_Confusion;
end Unlock;
or
accept Destroy_Self do
return; -- Terminate the task.
end Destroy_Self;
or
terminate;
end select;
----We are now locked; so accept any Unlock entry.
select
accept Unlock do
null;
end Unlock;
or
terminate;
end select;
end loop;
end X_Mutex_Rec;
--/ end if;
--\f
procedure Free_X_Mutex (M : in out X_Mutex) is
begin
--/ if not Multitask_Locking then
--//
--// Heap_Free_X_Mutex (M);
--//
--/ else
if M /= null then
M.Destroy_Self;
Heap_Free_X_Mutex (M);
end if;
--/ end if;
end Free_X_Mutex;
--\f
procedure Lock_Mutex (Mutex : X_Mutex) is
begin
--/ if not Multitask_Locking then
--// if Mutex.Flop = 0 then
--// Mutex.Flop := 1;
--// else
--// raise X_Library_Confusion;
--// end if;
--/ else
Mutex.Lock;
--/ end if;
end Lock_Mutex;
--\f
procedure Unlock_Mutex (Mutex : X_Mutex) is
begin
--/ if not Multitask_Locking then
--// if Mutex.Flop = 1 then
--// Mutex.Flop := 0;
--// else
--// raise X_Library_Confusion;
--// end if;
--/ else
Mutex.Unlock;
--/ end if;
end Unlock_Mutex;
--\f
--/ if cdf_Hpux then
--//
--// function Get_Errno return Status_Code is
--// use System_Interface.Error;
--// Err : Unix_Base_Types.Int := Errno;
--// begin
--//
--// if Err = Etimedout then
--// return Status_Code (Ewouldblock);
--// else
--// return Status_Code (Err);
--// end if;
--//
--// end Get_Errno;
--//
--/ elsif TeleGen2 and then Unix then
--//
--// function Get_Errno return Status_Code is
--// use Error_Messages;
--// Err : Errors := Errno;
--// begin
--//
--// if Err = Etimedout then
--// return Status_Code (Error_Messages.Ewouldblock);
--// else
--// return Status_Code (Err);
--// end if;
--//
--// end Get_Errno;
--//
--/ end if;
--\f
function Image (Code : Status_Code) return String is
begin
--/ if R1000 then
return Transport_Defs.Image (Code);
--/ else
--// return Status_Code'Image (Code);
--/ end if;
end Image;
--\f
end Xlbmt_Network_Types;