|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 16384 (0x4000)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Mail, package body Operations, package body Reply_Operations, seg_020b50
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Set_Generic;
with Unchecked_Deallocation;
with Unchecked_Conversions;
with String_Utilities;
package body Mail is
Data_Error : exception;
package Subscriptions is new Set_Generic (Mailbox);
package Su renames String_Utilities;
Number_Generator : Natural := 0;
All_Boxes : Post_Office.Map;
Subscription_List : Subscriptions.Set;
procedure Free is new Unchecked_Deallocation (Box, Mailbox);
procedure Free is new Unchecked_Deallocation (Raw_Message, Message_Pointer);
task Semaphore is
entry Unique_Number (N : out Natural);
end Semaphore;
task body Semaphore is separate;
task body Box is separate;
function Generate_Unique_Natural return Natural is separate;
----------------------------------------------------------------------
function Register (Name : String) return Mailbox is
New_Box : Mailbox := new Box;
begin
Post_Office.Define (The_Map => All_Boxes,
D => Su.Upper_Case (Su.Strip (Name)),
R => New_Box,
Trap_Multiples => True);
return New_Box;
exception
when Post_Office.Multiply_Defined =>
Free (New_Box);
raise Duplicate_Mailbox;
end Register;
procedure Add (Box : Mailbox; To : in out List) is
begin
To := List (Box_List.Make (Box, Box_List.List (To)));
end Add;
function Look_Up (Name : String) return Mailbox is
begin
return Post_Office.Eval (All_Boxes, Su.Upper_Case (Su.Strip (Name)));
exception
when Post_Office.Undefined =>
raise Undefined_Mailbox;
end Look_Up;
function Get_Kind (The_Message : Raw_Message) return Kind is
begin
return The_Message.Msg_Kind;
end Get_Kind;
function Get_Transaction_Id
(The_Message : Raw_Message) return Transaction_Id is
begin
return The_Message.Msg_Transaction_Id;
end Get_Transaction_Id;
function Is_A_Reply (The_Message : Raw_Message) return Boolean is
begin
return The_Message.Is_A_Reply;
end Is_A_Reply;
function Is_Empty (The_Message : Raw_Message) return Boolean is
begin
return The_Message.Is_Empty;
end Is_Empty;
function Response_Is_Required (The_Message : Raw_Message) return Boolean is
begin
return The_Message.Response_Is_Required;
end Response_Is_Required;
function Get_Response_Kind (The_Message : Raw_Message) return Kind is
begin
return The_Message.Response_Kind;
end Get_Response_Kind;
function Get_Priority (The_Message : Raw_Message) return Priority is
begin
return The_Message.Msg_Priority;
end Get_Priority;
function Wait (Box : Mailbox) return Raw_Message is
Msg : Message_Pointer;
begin
Box.Retrieve (Msg);
declare
Answer : constant Raw_Message := Msg.all;
begin
Free (Msg);
return Answer;
end;
end Wait;
function Conditional_Read (Box : Mailbox) return Raw_Message is
Empty_Message : constant Raw_Message :=
Raw_Message'(Length => 0,
Msg_Kind => 0,
Response_Kind => 0,
Msg_Priority => 0,
Msg_Transaction_Id =>
Transaction_Id'(Id => Integer'Last,
Source_Box => null,
Destination_Box => null),
Is_Empty => True,
Is_A_Reply => False,
Response_Is_Required => False,
Msg => (others => 0));
Msg : Message_Pointer;
begin
Box.Conditional_Retrieve (Msg);
if Msg = null then
return Empty_Message;
else
declare
Answer : constant Raw_Message := Msg.all;
begin
Free (Msg);
return Answer;
end;
end if;
end Conditional_Read;
package body Operations is
function To_Byte_String is
new Unchecked_Conversions.Convert_To_Byte_String (Message);
function From_Byte_String is
new Unchecked_Conversions.Convert_From_Byte_String (Message);
procedure Send_With_Delivery_Completion
(The_Message : Message;
Message_Priority : Priority := Default_Priority;
Destination : Mailbox) is
Blob : constant System.Byte_String := To_Byte_String (The_Message);
M : Raw_Message (Blob'Length) :=
Raw_Message'(Length => Blob'Length,
Msg_Kind => Message_Kind,
Response_Kind => Kind'Last,
Msg_Priority => Message_Priority,
Msg_Transaction_Id => Null_Transaction,
Is_Empty => False,
Is_A_Reply => False,
Response_Is_Required => False,
Msg => Blob);
begin
Destination.Deliver (M);
end Send_With_Delivery_Completion;
package body Reply_Operations is
function To_Byte_String is
new Unchecked_Conversions.Convert_To_Byte_String (Reply);
function From_Byte_String is
new Unchecked_Conversions.Convert_From_Byte_String (Reply);
function Send_Blocked_With_Application_Reply
(The_Message : Message;
Message_Priority : Priority := Default_Priority;
Destination : Mailbox) return Reply is
Response_Id : Response_Ids;
Reply_Pointer : Message_Pointer;
Blob : constant System.Byte_String :=
To_Byte_String (The_Message);
M : Raw_Message (Blob'Length) :=
Raw_Message'(Length => Blob'Length,
Msg_Kind => Message_Kind,
Response_Kind => Reply_Kind,
Msg_Priority => Message_Priority,
Msg_Transaction_Id =>
(Generate_Unique_Natural, null, Destination),
Is_A_Reply => False,
Is_Empty => False,
Response_Is_Required => True,
Msg => Blob);
begin
Destination.Deliver_With_Reply (M, Response_Id);
Destination.Accept_Response (Response_Id) (Reply_Pointer);
declare
Answer : constant Reply :=
From_Byte_String (Reply_Pointer.Msg);
begin
Free (Reply_Pointer);
return Answer;
end;
end Send_Blocked_With_Application_Reply;
function Send_Nonblocked_With_Application_Reply
(The_Message : Message;
Message_Priority : Priority := Default_Priority;
Source : Mailbox;
Destination : Mailbox) return Transaction_Id is
Blob : constant System.Byte_String :=
To_Byte_String (The_Message);
M : Raw_Message (Blob'Length) :=
Raw_Message'(Length => Blob'Length,
Msg_Kind => Message_Kind,
Response_Kind => Reply_Kind,
Msg_Priority => Message_Priority,
Msg_Transaction_Id => (Generate_Unique_Natural,
Source, Destination),
Is_A_Reply => False,
Is_Empty => False,
Response_Is_Required => True,
Msg => Blob);
begin
Destination.Deliver (M);
return M.Msg_Transaction_Id;
end Send_Nonblocked_With_Application_Reply;
function Receive (The_Message : Raw_Message) return Reply is
begin
if The_Message.Msg_Kind /= Reply_Kind then
raise Data_Error;
else
return From_Byte_String (The_Message.Msg);
end if;
end Receive;
procedure Nonblocked_Reply (The_Reply : Reply;
Transaction : Transaction_Id) is
Blob : constant System.Byte_String :=
To_Byte_String (The_Reply);
M : Raw_Message (Blob'Length) :=
Raw_Message'(Length => Blob'Length,
Msg_Kind => Reply_Kind,
Response_Kind => Kind'Last,
Msg_Priority => Default_Priority,
Msg_Transaction_Id => Transaction,
Is_A_Reply => True,
Is_Empty => False,
Response_Is_Required => False,
Msg => Blob);
begin
-- two cases: blocked or nonblocked sender
if Transaction.Source_Box = null then
-- blocked case
-- reply to my task queue, so that it may in turn
-- reply to the sender who is waiting
Transaction.Destination_Box.Respond (M);
else
-- unblocked case
-- return the reply to the sender's mailbox
Transaction.Source_Box.Deliver (M);
end if;
end Nonblocked_Reply;
end Reply_Operations;
procedure Multicast (The_Message : Message;
Message_Priority : Priority := Default_Priority;
Destinations : List) is
Iter : Box_List.Iterator;
begin
Box_List.Init (Iter, Box_List.List (Destinations));
while not Box_List.Done (Iter) loop
Send_With_Delivery_Completion
(The_Message => The_Message,
Message_Priority => Message_Priority,
Destination => Box_List.Value (Iter));
Box_List.Next (Iter);
end loop;
end Multicast;
procedure Broadcast (The_Message : Message;
Message_Priority : Priority := Default_Priority) is
Iter : Subscriptions.Iterator;
begin
Subscriptions.Init (Iter => Iter, S => Subscription_List);
while not Subscriptions.Done (Iter) loop
Send_With_Delivery_Completion
(The_Message => The_Message,
Message_Priority => Message_Priority,
Destination => Subscriptions.Value (Iter));
Subscriptions.Next (Iter);
end loop;
end Broadcast;
procedure Subscribe (Box : Mailbox) is
begin
Subscriptions.Add (S => Subscription_List, X => Box);
end Subscribe;
procedure Cancel_Subscription (Box : Mailbox) is
begin
Subscriptions.Delete (S => Subscription_List, X => Box);
end Cancel_Subscription;
function Receive (The_Message : Raw_Message) return Message is
begin
if The_Message.Msg_Kind /= Message_Kind then
raise Data_Error;
else
return From_Byte_String (The_Message.Msg);
end if;
end Receive;
end Operations;
begin
Post_Office.Initialize (All_Boxes);
Subscriptions.Initialize (Subscription_List);
end Mail;
nblk1=f
nid=0
hdr6=1e
[0x00] rec0=26 rec1=00 rec2=01 rec3=034
[0x01] rec0=1f rec1=00 rec2=02 rec3=01e
[0x02] rec0=1f rec1=00 rec2=03 rec3=01c
[0x03] rec0=19 rec1=00 rec2=04 rec3=02c
[0x04] rec0=00 rec1=00 rec2=0f rec3=014
[0x05] rec0=20 rec1=00 rec2=05 rec3=00a
[0x06] rec0=1a rec1=00 rec2=06 rec3=004
[0x07] rec0=13 rec1=00 rec2=07 rec3=04c
[0x08] rec0=01 rec1=00 rec2=0e rec3=000
[0x09] rec0=18 rec1=00 rec2=08 rec3=044
[0x0a] rec0=16 rec1=00 rec2=09 rec3=034
[0x0b] rec0=17 rec1=00 rec2=0a rec3=008
[0x0c] rec0=1a rec1=00 rec2=0b rec3=01e
[0x0d] rec0=16 rec1=00 rec2=0c rec3=046
[0x0e] rec0=15 rec1=00 rec2=0d rec3=000
tail 0x2171d2c9e838d44a1dd58 0x42a00088462061e03