pragma Style_Checks (All_Checks);
pragma Polling (Off);
pragma Suppress (All_Checks);
with System.Task_Primitives.Operations;
with Ada.Exceptions;
with System.Parameters;
package body System.Tasking.Protected_Objects.Single_Entry is
package STPO renames System.Task_Primitives.Operations;
use Parameters;
procedure Send_Program_Error
(Self_Id : Task_Id;
Entry_Call : Entry_Call_Link);
pragma Inline (Send_Program_Error);
procedure Wakeup_Entry_Caller
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link;
New_State : Entry_Call_State);
pragma Inline (Wakeup_Entry_Caller);
procedure Wait_For_Completion (Entry_Call : Entry_Call_Link);
pragma Inline (Wait_For_Completion);
procedure Wait_For_Completion_With_Timeout
(Entry_Call : Entry_Call_Link;
Wakeup_Time : Duration;
Mode : Delay_Modes);
procedure Check_Exception
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link);
pragma Inline (Check_Exception);
procedure PO_Do_Or_Queue
(Self_Id : Task_Id;
Object : Protection_Entry_Access;
Entry_Call : Entry_Call_Link);
procedure Check_Exception
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link)
is
pragma Warnings (Off, Self_ID);
procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
use type Ada.Exceptions.Exception_Id;
E : constant Ada.Exceptions.Exception_Id :=
Entry_Call.Exception_To_Raise;
begin
if E /= Ada.Exceptions.Null_Id then
Internal_Raise (E);
end if;
end Check_Exception;
procedure Send_Program_Error
(Self_Id : Task_Id;
Entry_Call : Entry_Call_Link)
is
Caller : constant Task_Id := Entry_Call.Self;
begin
Entry_Call.Exception_To_Raise := Program_Error'Identity;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Caller);
Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
STPO.Unlock (Caller);
if Single_Lock then
STPO.Unlock_RTS;
end if;
end Send_Program_Error;
procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is
Self_Id : constant Task_Id := Entry_Call.Self;
begin
Self_Id.Common.State := Entry_Caller_Sleep;
STPO.Sleep (Self_Id, Entry_Caller_Sleep);
Self_Id.Common.State := Runnable;
end Wait_For_Completion;
procedure Wait_For_Completion_With_Timeout
(Entry_Call : Entry_Call_Link;
Wakeup_Time : Duration;
Mode : Delay_Modes)
is
Self_Id : constant Task_Id := Entry_Call.Self;
Timedout : Boolean;
Yielded : Boolean;
use type Ada.Exceptions.Exception_Id;
begin
pragma Assert (Entry_Call.Mode = Timed_Call);
Self_Id.Common.State := Entry_Caller_Sleep;
STPO.Timed_Sleep
(Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded);
if Timedout then
Entry_Call.State := Cancelled;
else
Entry_Call.State := Done;
end if;
Self_Id.Common.State := Runnable;
end Wait_For_Completion_With_Timeout;
procedure Wakeup_Entry_Caller
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link;
New_State : Entry_Call_State)
is
pragma Warnings (Off, Self_ID);
Caller : constant Task_Id := Entry_Call.Self;
begin
pragma Assert (New_State = Done or else New_State = Cancelled);
pragma Assert
(Caller.Common.State /= Terminated and then
Caller.Common.State /= Unactivated);
Entry_Call.State := New_State;
STPO.Wakeup (Caller, Entry_Caller_Sleep);
end Wakeup_Entry_Caller;
procedure Complete_Single_Entry_Body (Object : Protection_Entry_Access) is
pragma Warnings (Off, Object);
begin
null;
end Complete_Single_Entry_Body;
procedure Exceptional_Complete_Single_Entry_Body
(Object : Protection_Entry_Access;
Ex : Ada.Exceptions.Exception_Id) is
begin
Object.Call_In_Progress.Exception_To_Raise := Ex;
end Exceptional_Complete_Single_Entry_Body;
procedure Initialize_Protection_Entry
(Object : Protection_Entry_Access;
Ceiling_Priority : Integer;
Compiler_Info : System.Address;
Entry_Body : Entry_Body_Access)
is
Init_Priority : Integer := Ceiling_Priority;
begin
if Init_Priority = Unspecified_Priority then
Init_Priority := System.Priority'Last;
end if;
STPO.Initialize_Lock (Init_Priority, Object.L'Access);
Object.Ceiling := System.Any_Priority (Init_Priority);
Object.Compiler_Info := Compiler_Info;
Object.Call_In_Progress := null;
Object.Entry_Body := Entry_Body;
Object.Entry_Queue := null;
end Initialize_Protection_Entry;
procedure Lock_Entry (Object : Protection_Entry_Access) is
Ceiling_Violation : Boolean;
begin
if Detect_Blocking then
declare
Self_Id : constant Task_Id := STPO.Self;
begin
Self_Id.Common.Protected_Action_Nesting :=
Self_Id.Common.Protected_Action_Nesting + 1;
end;
end if;
STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then
raise Program_Error;
end if;
end Lock_Entry;
procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is
Ceiling_Violation : Boolean;
begin
if Detect_Blocking then
declare
Self_Id : constant Task_Id := STPO.Self;
begin
Self_Id.Common.Protected_Action_Nesting :=
Self_Id.Common.Protected_Action_Nesting + 1;
end;
end if;
STPO.Read_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then
raise Program_Error;
end if;
end Lock_Read_Only_Entry;
procedure PO_Do_Or_Queue
(Self_Id : Task_Id;
Object : Protection_Entry_Access;
Entry_Call : Entry_Call_Link)
is
Barrier_Value : Boolean;
begin
Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1);
if Barrier_Value then
if Object.Call_In_Progress /= null then
Send_Program_Error (Self_Id, Entry_Call);
return;
end if;
Object.Call_In_Progress := Entry_Call;
Object.Entry_Body.Action
(Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
Object.Call_In_Progress := null;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Entry_Call.Self);
Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
STPO.Unlock (Entry_Call.Self);
if Single_Lock then
STPO.Unlock_RTS;
end if;
elsif Entry_Call.Mode /= Conditional_Call then
Object.Entry_Queue := Entry_Call;
else
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Entry_Call.Self);
Wakeup_Entry_Caller (Self_Id, Entry_Call, Cancelled);
STPO.Unlock (Entry_Call.Self);
if Single_Lock then
STPO.Unlock_RTS;
end if;
end if;
exception
when others =>
Send_Program_Error
(Self_Id, Entry_Call);
end PO_Do_Or_Queue;
function Protected_Count_Entry (Object : Protection_Entry) return Natural is
begin
if Object.Entry_Queue /= null then
return 1;
else
return 0;
end if;
end Protected_Count_Entry;
procedure Protected_Single_Entry_Call
(Object : Protection_Entry_Access;
Uninterpreted_Data : System.Address;
Mode : Call_Modes)
is
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
Ceiling_Violation : Boolean;
begin
if Detect_Blocking
and then Self_Id.Common.Protected_Action_Nesting > 0
then
Ada.Exceptions.Raise_Exception
(Program_Error'Identity, "potentially blocking operation");
end if;
STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then
raise Program_Error;
end if;
Entry_Call.Mode := Mode;
Entry_Call.State := Now_Abortable;
Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access);
Unlock_Entry (Object);
pragma Assert (Entry_Call.State /= Cancelled);
if Entry_Call.State /= Done then
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Self_Id);
Wait_For_Completion (Entry_Call'Access);
STPO.Unlock (Self_Id);
if Single_Lock then
STPO.Unlock_RTS;
end if;
end if;
Check_Exception (Self_Id, Entry_Call'Access);
end Protected_Single_Entry_Call;
function Protected_Single_Entry_Caller
(Object : Protection_Entry) return Task_Id is
begin
return Object.Call_In_Progress.Self;
end Protected_Single_Entry_Caller;
procedure Service_Entry (Object : Protection_Entry_Access) is
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
Caller : Task_Id;
begin
if Entry_Call /= null
and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1)
then
Object.Entry_Queue := null;
if Object.Call_In_Progress /= null then
Send_Program_Error (Self_Id, Entry_Call);
Unlock_Entry (Object);
return;
end if;
Object.Call_In_Progress := Entry_Call;
Object.Entry_Body.Action
(Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
Object.Call_In_Progress := null;
Caller := Entry_Call.Self;
Unlock_Entry (Object);
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Caller);
Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
STPO.Unlock (Caller);
if Single_Lock then
STPO.Unlock_RTS;
end if;
else
Unlock_Entry (Object);
end if;
exception
when others =>
Send_Program_Error (Self_Id, Entry_Call);
Unlock_Entry (Object);
end Service_Entry;
procedure Timed_Protected_Single_Entry_Call
(Object : Protection_Entry_Access;
Uninterpreted_Data : System.Address;
Timeout : Duration;
Mode : Delay_Modes;
Entry_Call_Successful : out Boolean)
is
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
Ceiling_Violation : Boolean;
begin
if Detect_Blocking
and then Self_Id.Common.Protected_Action_Nesting > 0
then
Ada.Exceptions.Raise_Exception
(Program_Error'Identity, "potentially blocking operation");
end if;
STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then
raise Program_Error;
end if;
Entry_Call.Mode := Timed_Call;
Entry_Call.State := Now_Abortable;
Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access);
Unlock_Entry (Object);
pragma Assert (Entry_Call.State /= Cancelled);
if Entry_Call.State = Done then
Check_Exception (Self_Id, Entry_Call'Access);
Entry_Call_Successful := True;
return;
end if;
if Single_Lock then
STPO.Lock_RTS;
else
STPO.Write_Lock (Self_Id);
end if;
Wait_For_Completion_With_Timeout (Entry_Call'Access, Timeout, Mode);
if Single_Lock then
STPO.Unlock_RTS;
else
STPO.Unlock (Self_Id);
end if;
pragma Assert (Entry_Call.State >= Done);
Check_Exception (Self_Id, Entry_Call'Access);
Entry_Call_Successful := Entry_Call.State = Done;
end Timed_Protected_Single_Entry_Call;
procedure Unlock_Entry (Object : Protection_Entry_Access) is
begin
if Detect_Blocking then
declare
Self_Id : constant Task_Id := Self;
begin
pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0);
Self_Id.Common.Protected_Action_Nesting :=
Self_Id.Common.Protected_Action_Nesting - 1;
end;
end if;
STPO.Unlock (Object.L'Access);
end Unlock_Entry;
end System.Tasking.Protected_Objects.Single_Entry;