Index: s-finmas.adb
===================================================================
--- s-finmas.adb	(revision 180365)
+++ s-finmas.adb	(working copy)
@@ -77,18 +77,28 @@
    procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is
    begin
       Lock_Task.all;
+      Attach_Unprotected (N, L);
+      Unlock_Task.all;
 
+      --  Note: No need to unlock in case of an exception because the above
+      --  code can never raise one.
+   end Attach;
+
+   ------------------------
+   -- Attach_Unprotected --
+   ------------------------
+
+   procedure Attach_Unprotected
+     (N : not null FM_Node_Ptr;
+      L : not null FM_Node_Ptr)
+   is
+   begin
       L.Next.Prev := N;
       N.Next := L.Next;
       L.Next := N;
       N.Prev := L;
+   end Attach_Unprotected;
 
-      Unlock_Task.all;
-
-      --  Note: No need to unlock in case of an exception because the above
-      --  code can never raise one.
-   end Attach;
-
    ---------------
    -- Base_Pool --
    ---------------
@@ -100,16 +110,14 @@
       return Master.Base_Pool;
    end Base_Pool;
 
-   -----------------------------
-   -- Delete_Finalize_Address --
-   -----------------------------
+   -----------------------------------------
+   -- Delete_Finalize_Address_Unprotected --
+   -----------------------------------------
 
-   procedure Delete_Finalize_Address (Obj : System.Address) is
+   procedure Delete_Finalize_Address_Unprotected (Obj : System.Address) is
    begin
-      Lock_Task.all;
       Finalize_Address_Table.Remove (Obj);
-      Unlock_Task.all;
-   end Delete_Finalize_Address;
+   end Delete_Finalize_Address_Unprotected;
 
    ------------
    -- Detach --
@@ -117,20 +125,27 @@
 
    procedure Detach (N : not null FM_Node_Ptr) is
    begin
+      Lock_Task.all;
+      Detach_Unprotected (N);
+      Unlock_Task.all;
+
+      --  Note: No need to unlock in case of an exception because the above
+      --  code can never raise one.
+   end Detach;
+
+   ------------------------
+   -- Detach_Unprotected --
+   ------------------------
+
+   procedure Detach_Unprotected (N : not null FM_Node_Ptr) is
+   begin
       if N.Prev /= null and then N.Next /= null then
-         Lock_Task.all;
-
          N.Prev.Next := N.Next;
          N.Next.Prev := N.Prev;
          N.Prev := null;
          N.Next := null;
-
-         Unlock_Task.all;
-
-         --  Note: No need to unlock in case of an exception because the above
-         --  code can never raise one.
       end if;
-   end Detach;
+   end Detach_Unprotected;
 
    --------------
    -- Finalize --
@@ -158,10 +173,14 @@
    --  Start of processing for Finalize
 
    begin
-      --  It is possible for multiple tasks to cause the finalization of the
-      --  same master. Let only one task finalize the objects.
+      Lock_Task.all;
 
+      --  Synchronization:
+      --    Read  - allocation, finalization
+      --    Write - finalization
+
       if Master.Finalization_Started then
+         Unlock_Task.all;
          return;
       end if;
 
@@ -170,13 +189,20 @@
       --  is explicitly deallocated or the associated access type is about to
       --  go out of scope.
 
+      --  Synchronization:
+      --    Read  - allocation, finalization
+      --    Write - finalization
+
       Master.Finalization_Started := True;
 
       while not Is_Empty_List (Master.Objects'Unchecked_Access) loop
          Curr_Ptr := Master.Objects.Next;
 
-         Detach (Curr_Ptr);
+         --  Synchronization:
+         --    Write - allocation, deallocation, finalization
 
+         Detach_Unprotected (Curr_Ptr);
+
          --  Skip the list header in order to offer proper object layout for
          --  finalization.
 
@@ -185,20 +211,28 @@
          --  Retrieve TSS primitive Finalize_Address depending on the master's
          --  mode of operation.
 
+         --  Synchronization:
+         --    Read  - allocation, finalization
+         --    Write - outside
+
          if Master.Is_Homogeneous then
+
+            --  Synchronization:
+            --    Read  - finalization
+            --    Write - allocation, outside
+
             Cleanup := Master.Finalize_Address;
+
          else
-            Cleanup := Finalize_Address (Obj_Addr);
+            --  Synchronization:
+            --    Read  - finalization
+            --    Write - allocation, deallocation
+
+            Cleanup := Finalize_Address_Unprotected (Obj_Addr);
          end if;
 
-         --  If Finalize_Address is not available, then this is most likely an
-         --  error in the expansion of the designated type or the allocator.
-
-         pragma Assert (Cleanup /= null);
-
          begin
             Cleanup (Obj_Addr);
-
          exception
             when Fin_Occur : others =>
                if not Raised then
@@ -210,11 +244,22 @@
          --  When the master is a heterogeneous collection, destroy the object
          --  - Finalize_Address pair since it is no longer needed.
 
+         --  Synchronization:
+         --    Read  - finalization
+         --    Write - outside
+
          if not Master.Is_Homogeneous then
-            Delete_Finalize_Address (Obj_Addr);
+
+            --  Synchronization:
+            --    Read  - finalization
+            --    Write - allocation, deallocation, finalization
+
+            Delete_Finalize_Address_Unprotected (Obj_Addr);
          end if;
       end loop;
 
+      Unlock_Task.all;
+
       --  If the finalization of a particular object failed or Finalize_Address
       --  was not set, reraise the exception now.
 
@@ -234,20 +279,16 @@
       return Master.Finalize_Address;
    end Finalize_Address;
 
-   ----------------------
-   -- Finalize_Address --
-   ----------------------
+   ----------------------------------
+   -- Finalize_Address_Unprotected --
+   ----------------------------------
 
-   function Finalize_Address
+   function Finalize_Address_Unprotected
      (Obj : System.Address) return Finalize_Address_Ptr
    is
-      Result : Finalize_Address_Ptr;
    begin
-      Lock_Task.all;
-      Result := Finalize_Address_Table.Get (Obj);
-      Unlock_Task.all;
-      return Result;
-   end Finalize_Address;
+      return Finalize_Address_Table.Get (Obj);
+   end Finalize_Address_Unprotected;
 
    --------------------------
    -- Finalization_Started --
@@ -463,36 +504,40 @@
       Fin_Addr_Ptr : Finalize_Address_Ptr)
    is
    begin
-      --  TSS primitive Finalize_Address is set at the point of allocation,
-      --  either through Allocate_Any_Controlled or through this routine.
-      --  Since multiple tasks can allocate on the same finalization master,
-      --  access to this attribute must be protected.
+      --  Synchronization:
+      --    Read  - finalization
+      --    Write - allocation, outside
 
       Lock_Task.all;
+      Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr);
+      Unlock_Task.all;
+   end Set_Finalize_Address;
 
+   --------------------------------------
+   -- Set_Finalize_Address_Unprotected --
+   --------------------------------------
+
+   procedure Set_Finalize_Address_Unprotected
+     (Master       : in out Finalization_Master;
+      Fin_Addr_Ptr : Finalize_Address_Ptr)
+   is
+   begin
       if Master.Finalize_Address = null then
          Master.Finalize_Address := Fin_Addr_Ptr;
       end if;
+   end Set_Finalize_Address_Unprotected;
 
-      Unlock_Task.all;
-   end Set_Finalize_Address;
+   ----------------------------------------------------
+   -- Set_Heterogeneous_Finalize_Address_Unprotected --
+   ----------------------------------------------------
 
-   ----------------------------------------
-   -- Set_Heterogeneous_Finalize_Address --
-   ----------------------------------------
-
-   procedure Set_Heterogeneous_Finalize_Address
+   procedure Set_Heterogeneous_Finalize_Address_Unprotected
      (Obj          : System.Address;
       Fin_Addr_Ptr : Finalize_Address_Ptr)
    is
    begin
-      --  Protected access is required in this case because
-      --  Finalize_Address_Table is a global data structure.
-
-      Lock_Task.all;
       Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr);
-      Unlock_Task.all;
-   end Set_Heterogeneous_Finalize_Address;
+   end Set_Heterogeneous_Finalize_Address_Unprotected;
 
    --------------------------
    -- Set_Is_Heterogeneous --
@@ -500,7 +545,13 @@
 
    procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is
    begin
+      --  Synchronization:
+      --    Read  - finalization
+      --    Write - outside
+
+      Lock_Task.all;
       Master.Is_Homogeneous := False;
+      Unlock_Task.all;
    end Set_Is_Heterogeneous;
 
 end System.Finalization_Masters;
Index: s-finmas.ads
===================================================================
--- s-finmas.ads	(revision 180365)
+++ s-finmas.ads	(working copy)
@@ -74,13 +74,23 @@
    for Finalization_Master_Ptr'Storage_Size use 0;
 
    procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr);
+   --  Compiler interface, do not call from withing the run-time. Prepend a
+   --  node to a specific finalization master.
+
+   procedure Attach_Unprotected
+     (N : not null FM_Node_Ptr;
+      L : not null FM_Node_Ptr);
    --  Prepend a node to a specific finalization master
 
-   procedure Delete_Finalize_Address (Obj : System.Address);
+   procedure Delete_Finalize_Address_Unprotected (Obj : System.Address);
    --  Destroy the relation pair object - Finalize_Address from the internal
    --  hash table.
 
    procedure Detach (N : not null FM_Node_Ptr);
+   --  Compiler interface, do not call from within the run-time. Remove a node
+   --  from an arbitrary finalization master.
+
+   procedure Detach_Unprotected (N : not null FM_Node_Ptr);
    --  Remove a node from an arbitrary finalization master
 
    overriding procedure Finalize (Master : in out Finalization_Master);
@@ -93,7 +103,7 @@
    --  Return a reference to the TSS primitive Finalize_Address associated with
    --  a master.
 
-   function Finalize_Address
+   function Finalize_Address_Unprotected
      (Obj : System.Address) return Finalize_Address_Ptr;
    --  Retrieve the Finalize_Address primitive associated with a particular
    --  object.
@@ -119,9 +129,15 @@
    procedure Set_Finalize_Address
      (Master       : in out Finalization_Master;
       Fin_Addr_Ptr : Finalize_Address_Ptr);
+   --  Compiler interface, do not call from within the run-time. Set the clean
+   --  up routine of a finalization master
+
+   procedure Set_Finalize_Address_Unprotected
+     (Master       : in out Finalization_Master;
+      Fin_Addr_Ptr : Finalize_Address_Ptr);
    --  Set the clean up routine of a finalization master
 
-   procedure Set_Heterogeneous_Finalize_Address
+   procedure Set_Heterogeneous_Finalize_Address_Unprotected
      (Obj          : System.Address;
       Fin_Addr_Ptr : Finalize_Address_Ptr);
    --  Add a relation pair object - Finalize_Address to the internal hash
@@ -165,11 +181,9 @@
       --  is used only when the master is in homogeneous mode.
 
       Finalization_Started : Boolean := False;
-      pragma Atomic (Finalization_Started);
       --  A flag used to detect allocations which occur during the finalization
       --  of a master. The allocations must raise Program_Error. This scenario
-      --  may arise in a multitask environment. The flag is atomic because it
-      --  is accessed without Lock_Task / Unlock_Task.
+      --  may arise in a multitask environment.
    end record;
 
    --  Since RTSfind cannot contain names of the form RE_"+", the following
Index: s-stposu.adb
===================================================================
--- s-stposu.adb	(revision 180365)
+++ s-stposu.adb	(working copy)
@@ -109,6 +109,9 @@
       N_Size  : Storage_Count;
       Subpool : Subpool_Handle := null;
 
+      Allocation_Locked : Boolean;
+      --  This flag stores the state of the associated collection
+
       Header_And_Padding : Storage_Offset;
       --  This offset includes the size of a FM_Node plus any additional
       --  padding due to a larger alignment.
@@ -156,22 +159,22 @@
          --  failed to create one. This is a serious error.
 
          if Context_Master = null then
-            raise Program_Error with "missing master in pool allocation";
-         end if;
+            raise Program_Error
+              with "missing master in pool allocation";
 
          --  If a subpool is present, then this is the result of erroneous
          --  allocator expansion. This is not a serious error, but it should
          --  still be detected.
 
-         if Context_Subpool /= null then
-            raise Program_Error with "subpool not required in pool allocation";
-         end if;
+         elsif Context_Subpool /= null then
+            raise Program_Error
+              with "subpool not required in pool allocation";
 
          --  If the allocation is intended to be on a subpool, but the access
          --  type's pool does not support subpools, then this is the result of
          --  erroneous end-user code.
 
-         if On_Subpool then
+         elsif On_Subpool then
             raise Program_Error
               with "pool of access type does not support subpools";
          end if;
@@ -187,10 +190,18 @@
 
       if Is_Controlled then
 
+         --  Synchronization:
+         --    Read  - allocation, finalization
+         --    Write - finalization
+
+         Lock_Task.all;
+         Allocation_Locked := Finalization_Started (Master.all);
+         Unlock_Task.all;
+
          --  Do not allow the allocation of controlled objects while the
          --  associated master is being finalized.
 
-         if Finalization_Started (Master.all) then
+         if Allocation_Locked then
             raise Program_Error with "allocation after finalization started";
          end if;
 
@@ -240,6 +251,7 @@
       --  Step 4: Attachment
 
       if Is_Controlled then
+         Lock_Task.all;
 
          --  Map the allocated memory into a FM_Node record. This converts the
          --  top of the allocated bits into a list header. If there is padding
@@ -262,8 +274,11 @@
 
          --  Prepend the allocated object to the finalization master
 
-         Attach (N_Ptr, Objects (Master.all));
+         --  Synchronization:
+         --    Write - allocation, deallocation, finalization
 
+         Attach_Unprotected (N_Ptr, Objects (Master.all));
+
          --  Move the address from the hidden list header to the start of the
          --  object. This operation effectively hides the list header.
 
@@ -275,19 +290,34 @@
          --    2) Named access types
          --    3) Most cases of anonymous access types usage
 
+         --  Synchronization:
+         --    Read  - allocation, finalization
+         --    Write - outside
+
          if Master.Is_Homogeneous then
-            Set_Finalize_Address (Master.all, Fin_Address);
 
+            --  Synchronization:
+            --    Read  - finalization
+            --    Write - allocation, outside
+
+            Set_Finalize_Address_Unprotected (Master.all, Fin_Address);
+
          --  Heterogeneous masters service the following:
 
          --    1) Allocations on / Deallocations from subpools
          --    2) Certain cases of anonymous access types usage
 
          else
-            Set_Heterogeneous_Finalize_Address (Addr, Fin_Address);
+            --  Synchronization:
+            --    Read  - finalization
+            --    Write - allocation, deallocation
+
+            Set_Heterogeneous_Finalize_Address_Unprotected (Addr, Fin_Address);
             Finalize_Address_Table_In_Use := True;
          end if;
 
+         Unlock_Task.all;
+
       --  Non-controlled allocation
 
       else
@@ -341,12 +371,18 @@
       --  Step 1: Detachment
 
       if Is_Controlled then
+         Lock_Task.all;
 
          --  Destroy the relation pair object - Finalize_Address since it is no
          --  longer needed.
 
          if Finalize_Address_Table_In_Use then
-            Delete_Finalize_Address (Addr);
+
+            --  Synchronization:
+            --    Read  - finalization
+            --    Write - allocation, deallocation
+
+            Delete_Finalize_Address_Unprotected (Addr);
          end if;
 
          --  Account for possible padding space before the header due to a
@@ -376,8 +412,11 @@
          --  action does not need to know the prior context used during
          --  allocation.
 
-         Detach (N_Ptr);
+         --  Synchronization:
+         --    Write - allocation, deallocation, finalization
 
+         Detach_Unprotected (N_Ptr);
+
          --  Move the address from the object to the beginning of the list
          --  header.
 
@@ -388,6 +427,8 @@
 
          N_Size := Storage_Size + Header_And_Padding;
 
+         Unlock_Task.all;
+
       else
          N_Addr := Addr;
          N_Size := Storage_Size;
