diff options
Diffstat (limited to 'gcc/ada/s-tpoben.adb')
| -rw-r--r-- | gcc/ada/s-tpoben.adb | 80 |
1 files changed, 72 insertions, 8 deletions
diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb index a195828c9b2..c1d7d3ccae4 100644 --- a/gcc/ada/s-tpoben.adb +++ b/gcc/ada/s-tpoben.adb @@ -44,6 +44,7 @@ with Ada.Exceptions; -- used for Exception_Occurrence_Access +-- Raise_Exception with System.Task_Primitives.Operations; -- used for Initialize_Lock @@ -72,6 +73,10 @@ package body System.Tasking.Protected_Objects.Entries is use Task_Primitives.Operations; use Ada.Exceptions; + ---------------- + -- Local Data -- + ---------------- + Locking_Policy : Character; pragma Import (C, Locking_Policy, "__gl_locking_policy"); @@ -216,13 +221,36 @@ package body System.Tasking.Protected_Objects.Entries is ------------------ procedure Lock_Entries - (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean) is + (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean) + is begin if Object.Finalized then Raise_Exception (Program_Error'Identity, "Protected Object is finalized"); end if; + -- If pragma Detect_Blocking is active then Program_Error must + -- be raised if this potentially blocking operation is called from + -- a protected action, and the protected object nesting level + -- must be increased. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := STPO.Self; + begin + if Self_Id.Common.Protected_Action_Nesting > 0 then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + else + -- We are entering in a protected action, so that we + -- increase the protected object nesting level. + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end if; + end; + end if; + -- The lock is made without defering abortion. -- Therefore the abortion has to be deferred before calling this @@ -239,14 +267,9 @@ package body System.Tasking.Protected_Objects.Entries is procedure Lock_Entries (Object : Protection_Entries_Access) is Ceiling_Violation : Boolean; - begin - if Object.Finalized then - Raise_Exception - (Program_Error'Identity, "Protected Object is finalized"); - end if; - pragma Assert (STPO.Self.Deferral_Level > 0); - Write_Lock (Object.L'Access, Ceiling_Violation); + begin + Lock_Entries (Object, Ceiling_Violation); if Ceiling_Violation then Raise_Exception (Program_Error'Identity, "Ceiling Violation"); @@ -259,12 +282,35 @@ package body System.Tasking.Protected_Objects.Entries is procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is Ceiling_Violation : Boolean; + begin if Object.Finalized then Raise_Exception (Program_Error'Identity, "Protected Object is finalized"); end if; + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action, and the protected object nesting level must + -- be increased. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := STPO.Self; + begin + if Self_Id.Common.Protected_Action_Nesting > 0 then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + else + -- We are entering in a protected action, so that we + -- increase the protected object nesting level. + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end if; + end; + end if; + Read_Lock (Object.L'Access, Ceiling_Violation); if Ceiling_Violation then @@ -278,6 +324,24 @@ package body System.Tasking.Protected_Objects.Entries is procedure Unlock_Entries (Object : Protection_Entries_Access) is begin + -- We are exiting from a protected action, so that we decrease the + -- protected object nesting level (if pragma Detect_Blocking is + -- active). + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + begin + -- Cannot call this procedure without being within a protected + -- action. + + 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; + Unlock (Object.L'Access); end Unlock_Entries; |