|
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: 20385 (0x4fa1)
Types: TextFile
Names: »B«
└─⟦afbc8121e⟧ Bits:30000532 8mm tape, Rational 1000, MC68020_OS2000 7_2_2
└─ ⟦77aa8350c⟧ »DATA«
└─⟦f794ecd1d⟧
└─⟦24d1ddd49⟧
└─⟦this⟧
-- The use of this system is subject to the software license terms and
-- conditions agreed upon between Rational and the Customer.
--
-- Copyright 1988 by Rational.
--
-- RESTRICTED RIGHTS LEGEND
--
-- Use, duplication, or disclosure by the Government is subject to
-- restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
-- Technical Data and Computer Software clause at 52.227-7013.
--
--
-- Rational
-- 3320 Scott Boulevard
-- Santa Clara, California 95054-3197
--
-- PROPRIETARY AND CONFIDENTIAL INFORMATION OF RATIONAL;
-- USE OR COPYING WITHOUT EXPRESS WRITTEN AUTHORIZATION
-- IS STRICTLY PROHIBITED. THIS MATERIAL IS PROTECTED AS
-- AN UNPUBLISHED WORK UNDER THE U.S. COPYRIGHT ACT OF
-- 1976. CREATED 1988. ALL RIGHTS RESERVED.
--
--
separate (Task_Management)
package body Message_Queue_Utilities is
pragma Suppress_All;
function Reply_Queue_Length
(The_Task : Task_Id; Current_Task : Task_Id) return Natural is
pragma Routine_Number (Runtime_Ids.Internal);
Status : Mq.Stratus;
Result : Natural;
The_Queue : Mq.Id
renames The_Task.Queues.Wait_List.List (Reply_Queue_Index).
Wait_Queue;
begin
Mq.Length (The_Queue, Status, Result);
-- if Safety_Check then
-- Checking.Check_Message_Queue_Status
-- (Status, Err.Bad_Status_From_Length,
-- Current_Task => Current_Task);
-- end if;
return Result;
end Reply_Queue_Length;
function Reply_Queue_Length (Current_Task : Task_Id) return Natural is
pragma Routine_Number (Runtime_Ids.Internal);
begin
return Reply_Queue_Length (Current_Task, Current_Task);
end Reply_Queue_Length;
-- function Retrieve_Entry_Call_Message
-- (Queue : Mq.Id;
-- Empty_Queue_Ok : Boolean := False;
-- Current_Task : Task_Id) return Entry_Call_Message is
-- Result : Entry_Call_Message;
-- Status : Mq.Stratus;
-- Actual_Size : Mq.Message_Size;
-- begin
-- Mq.Retrieve_Message (Queue, Result'Address,
-- Entry_Call_Message_Size, Status, Actual_Size);
--
-- if Empty_Queue_Ok and then Status = Mq.Q_Nomess then
-- return Null_Entry_Call_Message;
-- end if;
--
-- -- if Safety_Check then
-- -- Checking.Check_Message_Queue_Status
-- -- (Status, Err.Bad_Status_From_Retrieve_Message,
-- -- Current_Task => Current_Task);
-- --
-- -- if Actual_Size /= Entry_Call_Message_Size then
-- -- Runtime_Exceptions.Raise_Runtime_Error
-- -- ("Retrieve_Entry_Call_Message",
-- -- "bad size returned from Message_Queue.Retrieve_Message: " &
-- -- Mq.Message_Size'Image (Actual_Size),
-- -- Err.Bad_Size_From_Retrieve_Message,
-- -- Current_Task => Current_Task);
-- -- end if;
-- --
-- -- Checking.Check_Task (Result.Caller, "Retrieve_Entry_Call_Message",
-- -- Current_Task => Current_Task);
-- -- end if;
--
-- return Result;
-- end Retrieve_Entry_Call_Message;
--
-- function Retrieve_Reply
-- (Queue : Mq.Id; Current_Task : Task_Id) return Reply_Kind is
-- Reply_Msg : Reply_Message;
-- Status : Mq.Stratus;
-- Actual_Size : Mq.Message_Size;
-- begin
-- Mq.Retrieve_Message (Queue, Reply_Msg'Address,
-- Reply_Message_Size, Status, Actual_Size);
--
-- if Safety_Check then
-- Checking.Check_Message_Queue_Status
-- (Status, Err.Bad_Status_From_Retrieve_Message,
-- Current_Task => Current_Task);
-- if Actual_Size /= Reply_Message_Size then
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Retrieve_Reply",
-- "bad size returned from Message_Queue.Retrieve_Message: " &
-- Mq.Message_Size'Image (Actual_Size),
-- Err.Bad_Size_From_Retrieve_Message,
-- Current_Task => Current_Task);
-- end if;
-- end if;
--
-- return Reply_Msg.Kind;
-- end Retrieve_Reply;
procedure Await_Reply (Suspension_State : Suspension_Reason;
Reply : out Reply_Kind;
Current_Task : Task_Id) is
pragma Routine_Number (Runtime_Ids.Internal);
Wait_Item : Mq.Wait_Item
renames Current_Task.Queues.Wait_List.List (Reply_Queue_Index);
-- Status : Mq.Stratus;
Reply_Index : Mq.Wait_List_Index;
Reply_Msg : Reply_Message;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Await_Reply");
-- end if;
Current_Task.Suspension_State := Suspension_State;
Release_Lock;
Mq.Wait (Wait_Item'Address, 1, Reply_Index);
Reacquire_Lock;
-- if Safety_Check then
-- Checking.Check_Message_Queue_Status
-- (Status, Err.Bad_Status_From_Wait, Current_Task => Current_Task);
-- if Reply_Index /= 1 then
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Await_Reply",
-- "bad index returned from Message_Queue.Wait: " &
-- Mq.Wait_List_Index'Image (Reply_Index),
-- Err.Bad_Index_From_Wait,
-- Current_Task => Current_Task);
-- end if;
-- end if;
-- Local_Reply := Retrieve_Reply (Wait_Item.Wait_Queue,
-- Current_Task => Current_Task);
-- Reply := Local_Reply;
Mq.Retrieve_Message (Wait_Item.Wait_Queue,
Reply'Address, Reply_Message_Size);
-- if want to check status then
-- Mq.Retrieve_If_Available (Wait_Item.Wait_Queue, Reply'Address,
-- Reply_Message_Size, Status);
-- if Safety_Check then
--
-- if Suspension_State /= Current_Task.Suspension_State then
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Await_Reply",
-- "task suspension state was modified while task was awaiting reply",
-- Err.Suspension_State_Inconsistency,
-- Current_Task => Current_Task);
-- end if;
--
-- declare
-- procedure Check_Suspension_State
-- (Expected : Suspension_Reason) is
-- begin
-- if (Suspension_State /= Expected) or else
-- (Expected = Not_Suspended) then
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Await_Reply.Check_Suspension_State",
-- "received " & Reply_Kind'Image (Local_Reply) &
-- " reply after suspending in state " &
-- Suspension_Reason'Image (Suspension_State),
-- Err.Unexpected_Reply,
-- Current_Task => Current_Task);
-- end if;
-- end Check_Suspension_State;
--
-- begin
-- case Local_Reply is
-- when No_Reply =>
-- Check_Suspension_State (Not_Suspended);
-- when Delay_Stmt_Done =>
-- Check_Suspension_State (Delaying);
-- when Call_Timed_Out =>
-- Check_Suspension_State (Calling_Entry);
-- when Select_Timed_Out =>
-- Check_Suspension_State (Awaiting_Entry_Call);
-- when Activation_Group_Activated =>
-- Check_Suspension_State (Child_Activating);
-- when Rendezvous_Done =>
-- Check_Suspension_State (Calling_Entry);
-- when Dependents_Terminated =>
-- Check_Suspension_State (Awaiting_Dependent_Termination);
-- when Termination_Selected =>
-- Check_Suspension_State (Awaiting_Entry_Call);
-- when Task_Aborted =>
-- case Suspension_State is
-- when Calling_Entry |
-- Awaiting_Entry_Call | Delaying =>
-- null;
-- when others =>
-- Check_Suspension_State (Not_Suspended);
-- end case;
-- when Child_Tcb_Reclaimable =>
-- Check_Suspension_State (Awaiting_Tcb_Reclamation_Ok);
-- when Abortion_Acknowledged =>
-- Check_Suspension_State (Awaiting_Abortee_Reply);
-- end case;
-- end;
-- end if;
--
-- if Debug_Mode then
-- Debugging.Put_Message ("In Await_Reply, received reply = " &
-- Reply_Kind'Image (Local_Reply));
-- end if;
Current_Task.Suspension_State := Not_Suspended;
end Await_Reply;
procedure Send_Reply (To_Task : Task_Id;
Reply : Reply_Kind;
Current_Task : Task_Id) is
pragma Routine_Number (Runtime_Ids.Internal);
To_Queue : Mq.Id
renames To_Task.Queues.Wait_List.List (Reply_Queue_Index).
Wait_Queue;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Send_Reply, To_Task =" &
-- Integer'Image (To_Task.Os9_Process_Id) &
-- ", Reply = " & Reply_Kind'Image (Reply));
-- end if;
--
-- if Safety_Check then
-- Checking.Check_Task (To_Task, "Send_Reply",
-- Current_Task => Current_Task);
-- end if;
Mq.Send_Without_Priority (Value => Integer (Reply), Queue => To_Queue);
-- if Safety_Check then
-- if Debug_Mode and then (Status = Mq.Q_Full) then
-- declare
-- Length : Integer :=
-- Reply_Queue_Length (To_Task,
-- Current_Task => Current_Task);
-- begin
-- Debugging.Put_Message
-- ("*** In Send_Reply, recipient's reply queue is full; queue length = " &
-- Integer'Image (Length));
--
-- for I in 1 .. Length loop
-- Debugging.Put_Message
-- (" " & Integer'Image (I) & ": " &
-- Reply_Kind'Image
-- (Retrieve_Reply (To_Queue,
-- Current_Task => Current_Task)));
-- end loop;
-- end;
-- end if;
--
-- Checking.Check_Message_Queue_Status
-- (Status, Err.Bad_Status_From_Send_Without_Priority,
-- Current_Task => Current_Task);
-- end if;
--
-- if Debug_Mode then
-- if Message_Id = Mq.Null_Message then
-- Debugging.Put_Message
-- (" recipient was already awaiting reply");
-- else
-- Debugging.Put_Message
-- (" recipient was not already awaiting reply");
-- end if;
-- end if;
end Send_Reply;
procedure Purge_Reply_Queue (Current_Task : Task_Id) is
pragma Routine_Number (Runtime_Ids.Internal);
Result : Natural;
The_Queue : Mq.Id
renames Current_Task.Queues.Wait_List.List (Reply_Queue_Index).
Wait_Queue;
Length : Natural := Reply_Queue_Length (Current_Task => Current_Task);
Reply_Msg : Reply_Message;
Purged : Reply_Kind;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Purge_Reply_Queue");
-- end if;
if Length /= 0 then
for I in 1 .. Length loop
Mq.Retrieve_Message (The_Queue, Reply_Msg'Address,
Reply_Message_Size);
-- if Safety_Check then
-- case Reply_Msg.Kind is
-- when Delay_Stmt_Done | Call_Timed_Out |
-- Select_Timed_Out | Task_Aborted =>
-- if Debug_Mode then
-- Debugging.Put_Message
-- ("In Purge_Reply_Queue, purged reply = " &
-- Reply_Kind'Image (Reply_Msg.Kind));
-- end if;
-- when others =>
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Purge_Reply_Queue",
-- "Unexpected reply found in queue: " &
-- Reply_Kind'Image (Purged),
-- Err.Bad_Message_In_Queue,
-- Current_Task => Current_Task);
-- end case;
-- end if;
end loop;
-- if Safety_Check and then
-- (Reply_Queue_Length (Current_Task => Current_Task) /= 0) then
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Purge_Reply_Queue", "Reply queue length remains non-zero",
-- Err.Unemptiable_Queue,
-- Current_Task => Current_Task);
-- end if;
end if;
end Purge_Reply_Queue;
-- procedure Assert_Empty_Reply_Queue
-- (Caller : String; Current_Task : Task_Id) is
-- pragma Routine_Number (Runtime_Ids.Internal);
-- Length : Natural := Reply_Queue_Length (Current_Task => Current_Task);
-- begin
-- if Length /= 0 then
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Assert_Empty_Reply_Queue (called by " & Caller & ")",
-- "Reply queue length = " & Integer'Image (Length),
-- Err.Reply_Queue_Not_Empty,
-- Current_Task => Current_Task);
-- end if;
-- end Assert_Empty_Reply_Queue;
function Start_Timer
(Time : Duration; Reply : Reply_Kind; Current_Task : Task_Id)
return Timer.Id is
pragma Routine_Number (Runtime_Ids.Internal);
Reply_Queue : Mq.Id
renames Current_Task.Queues.Wait_List.List (Reply_Queue_Index).
Wait_Queue;
Status : Timer.Stratus;
Timer_Id : Timer.Id;
function Convert is new Unchecked_Conversion
(Source => Reply_Message,
Target => Timer.Timeout_Message);
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Start_Timer");
-- declare
-- function Convert is new Unchecked_Conversion
-- (Duration, Integer);
-- Ticks : Integer := Convert (Time);
-- begin
-- if Ticks mod 1024 = 0 then
-- Debugging.Put_Message
-- (" Time until expiration =" &
-- Integer'Image (Ticks / 1024) & " seconds");
-- else
-- Debugging.Put_Message (" Time until expiration =" &
-- Integer'Image (Ticks) &
-- " 1024ths of a second");
-- end if;
-- end;
-- Debugging.Put_Message (" Reply = " & Reply_Kind'Image (Reply));
-- end if;
-- if Safety_Check and then (Time < 0.0) then
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Start_Timer", "negative delay amount",
-- Err.Negative_Delay_Amount,
-- Current_Task => Current_Task);
-- end if;
Timer.Start (Time => Time,
Queue => Reply_Queue,
Signal => Convert (Reply_Message'(Kind => Reply)),
Result => Status,
Handle => Timer_Id);
case Status is
when Timer.Ti_Nofrte =>
-- if Debug_Mode then
-- Debugging.Put_Message
-- ("Start_Timer raising Storage_Error due to lack of available timers");
-- end if;
Runtime_Exceptions.Raise_Storage_Error;
when Timer.Ti_Nofrqs =>
-- if Debug_Mode then
-- Debugging.Put_Message
-- ("Start_Timer raising Storage_Error due to full message queue");
-- end if;
Runtime_Exceptions.Raise_Storage_Error;
when others =>
null;
-- if Safety_Check then
-- Checking.Check_Timer_Status
-- (Status, Err.Bad_Status_From_Start_Timer,
-- Current_Task => Current_Task);
-- if Timer_Id = Timer.Nil then
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Start_Timer", "Timer.Start returned nil timer_id",
-- Err.Bad_Id_From_Start_Timer,
-- Current_Task => Current_Task);
-- end if;
-- end if;
end case;
return Timer_Id;
end Start_Timer;
procedure Cancel_Timer (Timer_Id : Timer.Id;
Purge_If_Expired : Boolean := False;
Current_Task : Task_Id) is
pragma Routine_Number (Runtime_Ids.Internal);
Status : Timer.Stratus;
begin
if Timer_Id /= Timer.Nil then
Timer.Stop (Timer_Id, Status);
if Status = Timer.Ti_Btmrid then
if Purge_If_Expired then
Purge_Reply_Queue (Current_Task => Current_Task);
end if;
else
if Safety_Check then
Checking.Check_Timer_Status (Status,
Err.Bad_Status_From_Stop_Timer,
Current_Task => Current_Task);
end if;
end if;
-- if Debug_Mode then
-- if Status = Timer.Ti_Success then
-- Debugging.Put_Message ("Successful timer cancellation");
-- else
-- Debugging.Put_Message ("Unsuccessful timer cancellation");
-- end if;
-- end if;
end if;
end Cancel_Timer;
function Get_Associated_Data (For_Queue : Mq.Id; Current_Task : Task_Id)
return Mq.Associated_Data is
pragma Routine_Number (Runtime_Ids.Internal);
Data : Mq.Associated_Data;
Status : Mq.Stratus;
begin
Mq.Get_Associated_Data (For_Queue, Status, Data);
if Safety_Check then
Checking.Check_Message_Queue_Status
(Status, Err.Bad_Status_From_Associated_Data,
Current_Task => Current_Task);
end if;
return Data;
end Get_Associated_Data;
end Message_Queue_Utilities;
pragma Runtime_Unit (Unit_Number => Runtime_Ids.Runtime_Compunit,
Elab_Routine_Number => Runtime_Ids.Internal);