|
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: 39057 (0x9891)
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 Accepting_And_Selecting is
pragma Suppress_All;
-- procedure Await_Call (Wait_List : Tt.Wait_List_Skin;
-- Conditional : Boolean;
-- Selected : out Entry_Id;
-- Wakeup : out Reply_Kind;
-- Parameter_Location : Address_Ref;
-- Current_Task : Task_Id) is
-- pragma Routine_Number (Runtime_Ids.Internal);
-- --
-- -- Upon return, Wakeup contains a useful value iff
-- -- Selected = Null_Entry_Id.
--
-- Available : Mq.Wait_List_Index;
-- Call_Msg : Entry_Call_Message;
-- Status : Mq.Stratus;
-- Buffer : Integer := 0;
-- Retry : Boolean; -- only used in IPC case
-- begin
-- -- if Debug_Mode then
-- -- Debugging.Put_Message ("Entered Await_Call");
-- -- Debugging.Put_Message (" Wait_List'First =" &
-- -- Integer'Image (Wait_List.List'First) &
-- -- ", Wait_List'Last =" &
-- -- Integer'Image (Wait_List.List'Last));
-- -- Debugging.Put_Message (" Active Wait_List Elements =");
-- -- for I in Wait_List.List'Range loop
-- -- if not Wait_List.List (I).Not_Active then
-- -- if Wait_List.List (I).Ipc_Queue then
-- -- Debugging.Put_Message
-- -- (" " & Integer'Image (I) & " is IPC queue");
-- -- else
-- -- Debugging.Put_Message (" " & Integer'Image (I));
-- -- end if;
-- -- end if;
-- -- end loop;
-- -- end if;
-- --
-- -- if Safety_Check and then
-- -- not Current_Task.Action_State (Activation_Done) then
-- -- Runtime_Exceptions.Raise_Runtime_Error
-- -- ("Await_Call", "acceptor has not completed activation",
-- -- Err.Acceptor_Not_Done_Activating,
-- -- Current_Task => Current_Task);
-- -- end if;
--
-- Retry_Loop:
-- loop
-- -- Wakeup := No_Reply;
-- -- Call_Msg := Null_Entry_Call_Message;
--
-- if Conditional then
-- Mq.Wait_Nonblocking
-- (Wait_List.List'Address,
-- Wait_List.List'Length, Status, Available);
--
-- if Status = Mq.Q_Quesemp then
-- Selected := Null_Entry_Id;
-- Wakeup := No_Reply;
-- return;
-- end if;
--
-- -- if Safety_Check then
-- -- Checking.Check_Message_Queue_Status
-- -- (Status, Err.Bad_Status_From_Wait_Nonblocking,
-- -- Current_Task => Current_Task);
-- -- end if;
-- else
-- Current_Task.Suspension_State := Awaiting_Entry_Call;
-- Release_Lock;
-- Mq.Wait (Wait_List.List'Address,
-- Wait_List.List'Length, Available);
-- Reacquire_Lock;
--
-- -- if Debug_Mode then
-- -- Debugging.Put_Message ("Reply received in Await_Call");
-- -- end if;
-- --
-- -- if Safety_Check then
-- -- if Status = Mq.Q_Quedel then
-- -- if not Current_Task.Action_State (Abnormal) then
-- -- Runtime_Exceptions.Raise_Runtime_Error
-- -- ("Await_Call",
-- -- "queues deleted, but not abnormal",
-- -- Err.Reply_Queue_Already_Deleted,
-- -- Current_Task => Current_Task);
-- -- end if;
-- -- else
-- -- Checking.Check_Message_Queue_Status
-- -- (Status, Err.Bad_Status_From_Wait,
-- -- Current_Task => Current_Task);
-- -- end if;
-- -- end if;
--
-- Current_Task.Suspension_State := Not_Suspended;
-- end if;
--
-- if Current_Task.Action_State (Abnormal) then
-- Selected := Null_Entry_Id;
-- Wakeup := Task_Aborted;
-- Message_Queue_Utilities.Purge_Reply_Queue
-- (Current_Task => Current_Task);
-- return;
--
-- elsif Available = 1 then
-- Selected := Null_Entry_Id;
-- Mq.Retrieve_Message
-- (Wait_List.List (Reply_Queue_Index).Wait_Queue,
-- Wakeup'Address, Reply_Message_Size);
-- return;
-- else
-- -- Call_Msg := Message_Queue_Utilities.
-- -- Retrieve_Entry_Call_Message
-- -- (Wait_List.List (Available - 1).Wait_Queue,
-- -- Current_Task => Current_Task);
-- Mq.Retrieve_Message
-- (Wait_List.List (Available - 1).Wait_Queue,
-- Call_Msg'Address, Entry_Call_Message_Size);
-- if Call_Msg.Caller /= Null_Caller then
-- declare
-- The_Caller : Task_Id :=
-- To_Task_Id (Call_Msg.Caller);
-- begin
-- The_Caller.Callers_Link :=
-- Current_Task.Callers_Head;
-- Current_Task.Callers_Head.Next := The_Caller;
-- The_Caller.Partner_Priority :=
-- Current_Task.Current_Priority;
--
-- if Current_Task.Current_Priority <
-- The_Caller.Current_Priority then
-- Current_Task.Current_Priority :=
-- The_Caller.Current_Priority;
-- end if;
-- end;
--
-- if Call_Msg.Timer_Id /= Null_Timer then
-- Message_Queue_Utilities.Cancel_Timer
-- (Call_Msg.Timer_Id,
-- Current_Task => Current_Task);
-- end if;
-- exit Retry_Loop;
-- else -- IPC message
-- if Safety_Check and then
-- not Wait_List.List (Available - 1).Ipc_Queue then
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Await_Call", "IPC msg in non-IPC queue",
-- Err.Bad_Message_In_Queue,
-- Current_Task => Current_Task);
-- end if;
--
-- Buffer := Call_Msg.Rendezvous_Params;
--
-- -- Handle_Protocol may raise an exception, which
-- -- will try to Acquire lock
-- Release_Lock;
-- Ipc.Handle_Protocol
-- (Buffer => Buffer,
-- Slot_Data => Ipc.Message_Slot_Data
-- (Call_Msg.Timer_Id),
-- Queue_Data =>
-- Message_Queue_Utilities.Get_Associated_Data
-- (Wait_List.List (Available - 1).Wait_Queue,
-- Current_Task),
-- Parameters => Call_Msg.Rendezvous_Params,
-- Ignore_Message => Retry);
-- Reacquire_Lock;
--
-- exit when not Retry; -- only IPC case
-- end if;
-- end if;
-- end loop Retry_Loop;
--
-- Parameter_Location.all := Convert (Call_Msg.Rendezvous_Params);
--
-- if Buffer /= 0 or else Current_Task.Ipc_Buffer_List /= null then
-- if Debug_Mode then
-- Debugging.Put_Message (" creating buffer stack");
-- end if;
--
-- Current_Task.Ipc_Buffer_List :=
-- Storage_Manager.New_Buffer_Item
-- (With_Buffer => Buffer,
-- Slot_Data => Integer (Mq.Associated_Data
-- (Call_Msg.Timer_Id)),
-- Next_Item => Current_Task.Ipc_Buffer_List);
-- end if;
--
-- Selected := Entry_Id (Available - 1);
-- end Await_Call;
--
-- -- pragma Inline (Await_Call);
function Select_Rendezvous (Select_Var : Select_Info;
Round_Robin : in Integer; -- really in out
Parameter_Location : Address_Ref)
--return Alternative_Number is
--!!Kludge workaround for MP problem
return Integer is
pragma Routine_Number (Runtime_Ids.Select_Rendezvous);
Current_Task : constant Task_Id := Get_Current_Task_And_Acquire_Lock;
Wait_List : Wait_List_Skin renames Current_Task.Queues.Wait_List.all;
Branch_Table : Select_Branch_Table_Skin
renames Current_Task.Queues.Branch_Table.all;
subtype Index is Mq.Wait_List_Index;
The_Entry : Entry_Id;
Wakeup : Reply_Kind;
Delay_Time : Duration := Select_Var.Delay_Time;
Delay_Alternative_Open : constant Boolean :=
Select_Var.Form = Tt.Delay_Form and then Select_Var.Delay_Arm /= 0;
Terminate_Alternative_Open : constant Boolean :=
Select_Var.Form = Tt.Terminate_Form and then
Select_Var.Delay_Arm /= 0;
Else_Part_Present : constant Boolean := Select_Var.Form = Tt.Else_Form;
Treat_As_Else : constant Boolean :=
Else_Part_Present or else
(Delay_Alternative_Open and then Delay_Time <= 0.0);
Doing_Delay : constant Boolean :=
(Delay_Alternative_Open and then Delay_Time > 0.0);
Some_Accept_Open : Boolean := False;
Timer_Id : Timer.Id;
Call_Msg : Entry_Call_Message;
Result : Alternative_Number;
Available : Index;
Status : Mq.Stratus;
Buffer : Integer := 0;
Retry : Boolean; -- only used in IPC case
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Select_Rendezvous");
-- Debugging.Put_Message (" Form is " &
-- Select_Form'Image (Select_Var.Form));
-- Debugging.Put_Message (" Number of arms is " &
-- Alternative_Number'Image (Select_Var.Arms));
-- Debugging.Put_Message (" Delay arm is " &
-- Alternative_Number'Image
-- (Select_Var.Delay_Arm));
-- for I in 1 .. Select_Var.Arms loop
-- Debugging.Put_Message
-- ("Arm " & Alternative_Number'Image (I) & " maps to entry " &
-- Entry_Id'Image (Select_Var.Map (I).Entry_Number) &
-- " and quick => " &
-- Boolean'Image (Select_Var.Map (I).Quick));
-- end loop;
-- Debugging.Put_Message ("Delay open => " &
-- Boolean'Image (Delay_Alternative_Open));
-- Debugging.Put_Message ("Terminate open => " &
-- Boolean'Image (Terminate_Alternative_Open));
-- Debugging.Put_Message ("Else present => " &
-- Boolean'Image (Else_Part_Present));
-- Debugging.Put_Message ("Treating as else => " &
-- Boolean'Image (Treat_As_Else));
-- end if;
if Current_Task.Action_State (Abnormal) then
Runtime_Exceptions.Raise_Abnormal_Task_Error (Current_Task);
end if;
-- first close all entries
for I in First_Entry_Index .. Wait_List.List'Last loop
Wait_List.List (I).Not_Active := True;
end loop;
declare
The_Entry_Map : Tt.Entry_Vector renames Select_Var.Map;
begin
for I in 1 .. Select_Var.Arms loop
The_Entry := The_Entry_Map (I).Entry_Number;
if The_Entry /= Null_Entry_Id then
Wait_List.List (Mq.Wait_List_Index (The_Entry)).
Not_Active := False;
Branch_Table.Table (The_Entry) := I;
Some_Accept_Open := True;
end if;
end loop;
end;
-- if Debug_Mode then
-- Debugging.Put_Message (" Wait_List'First =" &
-- Integer'Image (Wait_List.List'First) &
-- ", Wait_List'Last =" &
-- Integer'Image (Wait_List.List'Last));
-- Debugging.Put_Message (" Active Wait_List Elements =");
-- for I in Wait_List.List'Range loop
-- if not Wait_List.List (I).Not_Active then
-- if Wait_List.List (I).Ipc_Queue then
-- Debugging.Put_Message
-- (" " & Integer'Image (I) & " is IPC queue");
-- else
-- Debugging.Put_Message (" " & Integer'Image (I));
-- end if;
-- end if;
-- end loop;
-- end if;
if not Some_Accept_Open and then not Delay_Alternative_Open and then
not Terminate_Alternative_Open and then not Else_Part_Present then
Runtime_Exceptions.Raise_Program_Error;
end if;
if Doing_Delay then
Timer_Id := Message_Queue_Utilities.Start_Timer
(Delay_Time, Select_Timed_Out,
Current_Task => Current_Task);
elsif Terminate_Alternative_Open then
Termination_And_Abortion.Make_Eligible_For_Termination
(Current_Task => Current_Task);
end if;
-- Await_Call (Current_Task => Current_Task,
-- Wait_List => Wait_List,
-- Conditional => Treat_As_Else,
-- Selected => The_Entry,
-- Wakeup => Wakeup,
-- Parameter_Location => Parameter_Location);
<<Await_Call_In_Select>> null;
if Treat_As_Else then
Mq.Wait_Nonblocking (Wait_List.List'Address,
Wait_List.List'Length, Status, Available);
if Status = Mq.Q_Quesemp or else -- no callers
Status = Mq.Q_Empws then -- no open alternatives
Release_Lock;
if Else_Part_Present then
return 0;
else -- non-positive delay
--!! Kludge
return Integer (Select_Var.Delay_Arm);
end if;
end if;
-- if Safety_Check then
-- Checking.Check_Message_Queue_Status
-- (Status, Err.Bad_Status_From_Wait_Nonblocking,
-- Current_Task => Current_Task);
-- end if;
else
Current_Task.Suspension_State := Awaiting_Entry_Call;
Release_Lock;
Mq.Wait (Wait_List.List'Address, Wait_List.List'Length, Available);
Reacquire_Lock;
-- if Debug_Mode then
-- Debugging.Put_Message ("Reply received in Select_Rendezvous");
-- end if;
--
-- if Safety_Check then
-- if Status = Mq.Q_Quedel then
-- if not Current_Task.Action_State (Abnormal) then
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Select_Rendezvous",
-- "queues deleted, but not abnormal",
-- Err.Reply_Queue_Already_Deleted,
-- Current_Task => Current_Task);
-- end if;
-- else
-- Checking.Check_Message_Queue_Status
-- (Status, Err.Bad_Status_From_Wait,
-- Current_Task => Current_Task);
-- end if;
-- end if;
Current_Task.Suspension_State := Not_Suspended;
if Current_Task.Action_State (Abnormal) then
Message_Queue_Utilities.Purge_Reply_Queue
(Current_Task => Current_Task);
if Terminate_Alternative_Open then
Termination_And_Abortion.Make_Ineligible_For_Termination
(Current_Task => Current_Task);
elsif Doing_Delay then
Message_Queue_Utilities.Cancel_Timer
(Timer_Id, Current_Task => Current_Task);
end if;
Runtime_Exceptions.Raise_Abnormal_Task_Error
(Current_Task => Current_Task);
end if;
end if;
The_Entry := Entry_Id (Available - 1);
if The_Entry = Null_Entry_Id then
Mq.Retrieve_Message (Wait_List.List (Reply_Queue_Index).Wait_Queue,
Wakeup'Address, Reply_Message_Size);
if Terminate_Alternative_Open then
if Safety_Check then
Checking.Check_Reply (Wakeup, Termination_Selected,
Current_Task => Current_Task);
end if;
Current_Task.Action_State (Selecting_Termination) := True;
Runtime_Exceptions.Raise_Force_Term_Error
(Current_Task => Current_Task);
elsif Doing_Delay then
if Safety_Check then
Checking.Check_Reply (Wakeup, Select_Timed_Out,
Current_Task => Current_Task);
end if;
Release_Lock;
--!!Kludge
return Integer (Select_Var.Delay_Arm);
elsif Safety_Check then
Runtime_Exceptions.Raise_Runtime_Error
("Select_Rendezvous",
"unexpected wakeup reason: " & Reply_Kind'Image (Wakeup),
Err.Unexpected_Reply,
Current_Task => Current_Task);
end if;
else
-- Call_Msg := Message_Queue_Utilities.
-- Retrieve_Entry_Call_Message
-- (Wait_List.List (Index (The_Entry)).Wait_Queue,
-- Current_Task => Current_Task);
Mq.Retrieve_Message (Wait_List.List (Index (The_Entry)).Wait_Queue,
Call_Msg'Address, Entry_Call_Message_Size);
if Terminate_Alternative_Open then
Termination_And_Abortion.Make_Ineligible_For_Termination
(Current_Task => Current_Task);
elsif Doing_Delay then
Message_Queue_Utilities.Cancel_Timer
(Timer_Id,
Purge_If_Expired => True,
Current_Task => Current_Task);
end if;
if Call_Msg.Caller /= Null_Caller then
declare
The_Caller : Task_Id := To_Task_Id (Call_Msg.Caller);
begin
The_Caller.Callers_Link := Current_Task.Callers_Head;
Current_Task.Callers_Head.Next := The_Caller;
The_Caller.Partner_Priority :=
Current_Task.Current_Priority;
if Current_Task.Current_Priority <
The_Caller.Current_Priority then
Current_Task.Current_Priority :=
The_Caller.Current_Priority;
end if;
end;
if Call_Msg.Timer_Id /= Null_Timer then
Message_Queue_Utilities.Cancel_Timer
(Call_Msg.Timer_Id, Current_Task => Current_Task);
end if;
else
-- IPC message
-- if Safety_Check and then
-- not Wait_List.List (Index (The_Entry)).Ipc_Queue then
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Select_Rendezvous", "IPC msg in non-IPC queue",
-- Err.Bad_Message_In_Queue,
-- Current_Task => Current_Task);
-- end if;
Buffer := Call_Msg.Rendezvous_Params;
-- Handle_Protocol may raise an exception, which
-- will try to Acquire lock
Release_Lock;
Ipc.Handle_Protocol
(Buffer => Buffer,
Slot_Data => Ipc.Message_Slot_Data (Call_Msg.Timer_Id),
Queue_Data =>
Message_Queue_Utilities.Get_Associated_Data
(Wait_List.List (Index (The_Entry)).Wait_Queue,
Current_Task),
Parameters => Call_Msg.Rendezvous_Params,
Ignore_Message => Retry);
Reacquire_Lock;
if Retry then
goto Await_Call_In_Select;
end if;
end if;
end if;
Parameter_Location.all := Convert (Call_Msg.Rendezvous_Params);
Result := Branch_Table.Table (The_Entry);
if Buffer /= 0 or else Current_Task.Ipc_Buffer_List /= null then
-- if Debug_Mode then
-- Debugging.Put_Message (" creating buffer item");
-- end if;
-- Storage_Manager.New_Buffer_Item will release the lock
--
Current_Task.Ipc_Buffer_List :=
Storage_Manager.New_Buffer_Item
(With_Buffer => Buffer,
Slot_Data => Integer (Mq.Associated_Data
(Call_Msg.Timer_Id)),
Next_Item => Current_Task.Ipc_Buffer_List);
else
Release_Lock;
end if;
if Select_Var.Map (Result).Quick then
End_Accept (With_Exception => False);
end if;
-- if Safety_Check then
-- Message_Queue_Utilities.Assert_Empty_Reply_Queue
-- ("Select_Rendezvous", Current_Task => Current_Task);
-- end if;
--
-- if Debug_Mode then
-- Debugging.Put_Message ("Select_Rendezvous returning" &
-- Alternative_Number'Image (Result));
-- end if;
--!!Kludge
return Integer (Result);
end Select_Rendezvous;
procedure Begin_Accept (For_Entry : Entry_Id;
Parameter_Location : Address_Ref) is
pragma Routine_Number (Runtime_Ids.Begin_Accept);
Current_Task : constant Task_Id := Get_Current_Task_And_Acquire_Lock;
Entry_Wait_Item : Mq.Wait_Item
renames Current_Task.Queues.Wait_List.all.List
(Integer (For_Entry));
Accept_Wait_List : Wait_List_Skin
renames Current_Task.Queues.Accept_List.all;
-- reply queue already set up as 0th element of accept list
Available : Mq.Wait_List_Index;
Call_Msg : Entry_Call_Message;
Buffer : Integer := 0;
Retry : Boolean; -- only used in IPC case
begin
-- use the explicit representation of queue id here is a real
-- kludge, but better code is generated.
Accept_Wait_List.List (1).Wait_Queue.Upper :=
Entry_Wait_Item.Wait_Queue.Upper;
Accept_Wait_List.List (1).Wait_Queue.Lower :=
Entry_Wait_Item.Wait_Queue.Lower;
-- .. List (1).Not_Active already false
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Begin_Accept, Entry_Number =" &
-- Integer'Image (Integer (For_Entry)));
-- end if;
--Runtime_Exceptions.Check_For_Abnormality (Current_Task => Current_Task);
if Current_Task.Action_State (Abnormal) then
Runtime_Exceptions.Raise_Abnormal_Task_Error
(Current_Task => Current_Task);
end if;
<<Await_Call_In_Accept>> null;
Current_Task.Suspension_State := Awaiting_Entry_Call;
Release_Lock;
Mq.Wait (Accept_Wait_List.List'Address,
Accept_Wait_List.List'Length, Available);
Reacquire_Lock;
Current_Task.Suspension_State := Not_Suspended;
-- the only possible outcomes from the wait for an accept
-- are an abort message in the reply queue or an entry
-- call message in the entry queue
if Current_Task.Action_State (Abnormal) then
Message_Queue_Utilities.Purge_Reply_Queue
(Current_Task => Current_Task);
Runtime_Exceptions.Raise_Abnormal_Task_Error
(Current_Task => Current_Task);
else
-- Call_Msg := Message_Queue_Utilities.
-- Retrieve_Entry_Call_Message
-- (Wait_List.List (Available - 1).Wait_Queue,
-- Current_Task => Current_Task);
Mq.Retrieve_Message (Accept_Wait_List.List (1).Wait_Queue,
Call_Msg'Address, Entry_Call_Message_Size);
if Call_Msg.Caller /= Null_Caller then
declare
The_Caller : Task_Id := To_Task_Id (Call_Msg.Caller);
begin
The_Caller.Callers_Link := Current_Task.Callers_Head;
Current_Task.Callers_Head.Next := The_Caller;
The_Caller.Partner_Priority :=
Current_Task.Current_Priority;
if Current_Task.Current_Priority <
The_Caller.Current_Priority then
Current_Task.Current_Priority :=
The_Caller.Current_Priority;
end if;
end;
if Call_Msg.Timer_Id /= Null_Timer then
Message_Queue_Utilities.Cancel_Timer
(Call_Msg.Timer_Id, Current_Task => Current_Task);
end if;
else -- IPC message
Buffer := Call_Msg.Rendezvous_Params;
-- Handle_Protocol may raise an exception, which
-- will try to Acquire lock
Release_Lock;
Ipc.Handle_Protocol
(Buffer => Buffer,
Slot_Data => Ipc.Message_Slot_Data (Call_Msg.Timer_Id),
Queue_Data => Message_Queue_Utilities.Get_Associated_Data
(Accept_Wait_List.List (1).Wait_Queue,
Current_Task),
Parameters => Call_Msg.Rendezvous_Params,
Ignore_Message => Retry);
Reacquire_Lock;
if Retry then
goto Await_Call_In_Accept;
end if;-- only IPC case
end if;
end if;
Parameter_Location.all := Convert (Call_Msg.Rendezvous_Params);
if Buffer /= 0 or else Current_Task.Ipc_Buffer_List /= null then
-- Storage_Manager.New_Buffer_Item will release the lock
--
Current_Task.Ipc_Buffer_List :=
Storage_Manager.New_Buffer_Item
(With_Buffer => Buffer,
Slot_Data => Integer (Mq.Associated_Data
(Call_Msg.Timer_Id)),
Next_Item => Current_Task.Ipc_Buffer_List);
else
Release_Lock;
end if;
end Begin_Accept;
procedure End_Accept (With_Exception : Boolean) is
pragma Routine_Number (Runtime_Ids.End_Accept);
Current_Task : constant Task_Id := Get_Current_Task_And_Acquire_Lock;
Have_Buffer_Stack : constant Boolean :=
(Current_Task.Ipc_Buffer_List /= null);
Caller : Task_Id;
Prior_Priority : Priority;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered End_Accept with exception => " &
-- Boolean'Image (With_Exception));
-- end if;
if not Have_Buffer_Stack or else
Current_Task.Ipc_Buffer_List.Buffer = 0 then
-- not an IPC rendezvous
Caller := Current_Task.Callers_Head.Next;
Prior_Priority := Caller.Partner_Priority;
-- if Safety_Check then
-- Checking.Check_Task (Caller, "End_Accept",
-- Current_Task => Current_Task);
-- end if;
if Current_Task.Action_State (Abnormal) then
Caller.Exception_Id := Exceptions.Tasking_Error;
Caller.Action_State (Exception_Pending) := True;
elsif With_Exception then
Caller.Exception_Id := Current_Task.Exception_Id;
Caller.Action_State (Exception_Pending) := True;
end if;
Current_Task.Callers_Head := Caller.Callers_Link;
Caller.Callers_Link.Next := null;
-- Message_Queue_Utilities.Send_Reply
-- (Caller, Rendezvous_Done, Current_Task => Current_Task);
declare
Status : Mq.Stratus;
Message_Id : Mq.Message_Id;
The_Reply : Reply_Kind := Rendezvous_Done;
begin
Mq.Send_Without_Priority
(Value => Integer (Rendezvous_Done),
Queue => Caller.Queues.Wait_List.List (Reply_Queue_Index).
Wait_Queue);
end;
if Prior_Priority /= Current_Task.Current_Priority then
Current_Task.Current_Priority := Prior_Priority;
declare
Reset_Priority : Integer := Integer (Prior_Priority);
begin
if Reset_Priority < Minimum_Os_Priority then
Reset_Priority := Minimum_Os_Priority;
end if;
Release_Lock;
Process_Ops.Set_Priority
(Process_Id => Current_Task.Process_Id,
Priority => Reset_Priority);
-- if Safety_Check then
-- Checking.Check_Os9_Ops_Status
-- (Status, Err.Bad_Status_From_Set_Priority,
-- Current_Task => Current_Task);
-- end if;
end;
else
Release_Lock;
end if;
else -- an IPC rendezvous
Release_Lock;
Ipc.Release_Buffer (Current_Task.Ipc_Buffer_List.Buffer,
Ipc.Message_Slot_Data
(Current_Task.Ipc_Buffer_List.Slot_Data));
Current_Task.Ipc_Buffer_List.Buffer := 0;
end if;
if Have_Buffer_Stack then -- pop a level
declare
Temp : Buffer_List := Current_Task.Ipc_Buffer_List.Next;
begin
Current_Task.Ipc_Buffer_List.Next := Buffer_Free_List;
Buffer_Free_List := Current_Task.Ipc_Buffer_List;
Current_Task.Ipc_Buffer_List := Temp;
end;
end if;
--Runtime_Exceptions.Check_For_Abnormality (Current_Task => Current_Task);
if Current_Task.Action_State (Abnormal) then
-- must reacquire lock, since already released, and
-- raise will also release.
Reacquire_Lock;
Runtime_Exceptions.Raise_Abnormal_Task_Error
(Current_Task => Current_Task);
end if;
end End_Accept;
procedure Quick_Accept (For_Entry : Entry_Id) is
pragma Routine_Number (Runtime_Ids.Quick_Accept);
Current_Task : constant Task_Id := Get_Current_Task_And_Acquire_Lock;
Entry_Wait_Item : Mq.Wait_Item
renames Current_Task.Queues.Wait_List.all.List
(Integer (For_Entry));
Accept_Wait_List : Wait_List_Skin
renames Current_Task.Queues.Accept_List.all;
-- reply queue already set up as 0th element of accept list
Available : Mq.Wait_List_Index;
Call_Msg : Entry_Call_Message;
-- NOTE: assume that all IPC messages have paraemeters, and
-- hence will never be accepted via Quick_Accept.
--
begin
-- do work of Begin_Accept
-- use the explicit representation of queue id here is a real
-- kludge, but better code is generated.
Accept_Wait_List.List (1).Wait_Queue.Upper :=
Entry_Wait_Item.Wait_Queue.Upper;
Accept_Wait_List.List (1).Wait_Queue.Lower :=
Entry_Wait_Item.Wait_Queue.Lower;
-- .. List (1).Not_Active already false
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Quick_Accept, Entry_Number =" &
-- Integer'Image (Integer (For_Entry)));
-- end if;
--Runtime_Exceptions.Check_For_Abnormality (Current_Task => Current_Task);
if Current_Task.Action_State (Abnormal) then
Runtime_Exceptions.Raise_Abnormal_Task_Error
(Current_Task => Current_Task);
end if;
Current_Task.Suspension_State := Awaiting_Entry_Call;
Release_Lock;
Mq.Wait (Accept_Wait_List.List'Address,
Accept_Wait_List.List'Length, Available);
Reacquire_Lock;
Current_Task.Suspension_State := Not_Suspended;
-- the only possible outcomes from the wait for an accept
-- are an abort message in the reply queue or an entry
-- call message in the entry queue
if Current_Task.Action_State (Abnormal) then
Message_Queue_Utilities.Purge_Reply_Queue
(Current_Task => Current_Task);
-- raise will release the lock
Runtime_Exceptions.Raise_Abnormal_Task_Error
(Current_Task => Current_Task);
else
-- Call_Msg := Message_Queue_Utilities.
-- Retrieve_Entry_Call_Message
-- (Wait_List.List (Available - 1).Wait_Queue,
-- Current_Task => Current_Task);
Mq.Retrieve_Message (Accept_Wait_List.List (1).Wait_Queue,
Call_Msg'Address, Entry_Call_Message_Size);
declare
The_Caller : Task_Id := To_Task_Id (Call_Msg.Caller);
begin
if Call_Msg.Timer_Id /= Null_Timer then
Message_Queue_Utilities.Cancel_Timer
(Call_Msg.Timer_Id, Current_Task => Current_Task);
end if;
-- do work of End_Accept (With_Exception => False);
-- Message_Queue_Utilities.Send_Reply
-- (Caller, Rendezvous_Done, Current_Task => Current_Task);
declare
Status : Mq.Stratus;
Message_Id : Mq.Message_Id;
The_Reply : Reply_Kind := Rendezvous_Done;
begin
Mq.Send_Without_Priority
(Value => Integer (Rendezvous_Done),
Queue => The_Caller.Queues.Wait_List.List
(Reply_Queue_Index).Wait_Queue);
end;
if Current_Task.Current_Priority <
The_Caller.Current_Priority then
declare
Reset_Priority : Integer :=
Integer (Current_Task.Current_Priority);
begin
if Reset_Priority < Minimum_Os_Priority then
Reset_Priority := Minimum_Os_Priority;
end if;
Release_Lock;
Process_Ops.Set_Priority
(Process_Id => Current_Task.Process_Id,
Priority => Reset_Priority);
-- if Safety_Check then
-- Checking.Check_Os9_Ops_Status
-- (Status, Err.Bad_Status_From_Set_Priority,
-- Current_Task => Current_Task);
-- end if;
end;
else
Release_Lock;
end if;
end;
end if;
end Quick_Accept;
end Accepting_And_Selecting;
pragma Runtime_Unit (Unit_Number => Runtime_Ids.Runtime_Compunit,
Elab_Routine_Number => Runtime_Ids.Internal);