2005-06-14 Matthew Heaney <heaney@adacore.com>

	* a-swunha.ads, a-swunha.adb: Removed. Replaced by a-swuwha.ad[sb]
	* a-swuwha.ads, a-swuwha.adb: New files

	* a-szunha.ads, a-szunha.adb: Removed, replaced by a-szuzha.ad[sb]
	* a-szuzha.ads, a-szuzha.adb: New files.

	* a-rbtgso.adb, a-crbtgo.ads, a-crbtgo.adb, a-crbtgk.ads,
	a-crbtgk.adb, a-crbltr.ads, a-coorse.ads, a-coorse.adb, a-convec.ads,
	a-convec.adb, a-coinve.ads, a-coinve.adb, a-cohata.ads, a-cohama.ads,
	a-cohama.adb, a-ciorse.ads, a-ciorse.adb, a-cihama.ads, a-cihama.adb,
	a-cidlli.ads, a-cidlli.adb, a-chtgop.ads, a-chtgop.adb, a-cdlili.ads,
	a-cdlili.adb, a-coormu.adb, a-ciormu.adb, a-cihase.adb, a-cohase.adb,
	a-cohase.ads, a-ciorma.ads, a-coorma.ads, a-ciormu.ads, a-coormu.ads,
	a-swunha.adb, a-stunha.adb, a-ciorma.adb, a-coorma.adb, a-shcain.ads,
	a-shcain.adb, a-chtgke.ads, a-chtgke.adb, a-stwiha.ads, a-stwiha.adb,
	a-strhas.adb, a-stzhas.adb: synchronized to the latest version of the
	Ada 2005 RM.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@101069 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 364 insertions, 432 deletions

diff --git a/gcc/ada/a-coormu.adb b/gcc/ada/a-coormu.adb
index 20712960bf9..387abfb7ff2 100644
--- a/gcc/ada/a-coormu.adb
+++ b/gcc/ada/a-coormu.adb
@@ -2,11 +2,11 @@
 --                                                                          --
 --                         GNAT LIBRARY COMPONENTS                          --
 --                                                                          --
---                     ADA.CONTAINERS.ORDERED_MULTISETS                     --
+--     A D A . C O N T A I N E R S . O R D E R E D _ M U L T I S E T S      --
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---             Copyright (C) 2004 Free Software Foundation, Inc.            --
+--          Copyright (C) 2004-2005 Free Software Foundation, Inc.          --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -44,20 +44,8 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
 with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
 
-with System;  use type System.Address;
-
 package body Ada.Containers.Ordered_Multisets is
 
-   use Red_Black_Trees;
-
-   type Node_Type is limited record
-      Parent  : Node_Access;
-      Left    : Node_Access;
-      Right   : Node_Access;
-      Color   : Red_Black_Trees.Color_Type := Red;
-      Element : Element_Type;
-   end record;
-
    -----------------------------
    -- Node Access Subprograms --
    -----------------------------
@@ -96,10 +84,6 @@ package body Ada.Containers.Ordered_Multisets is
    function Copy_Node (Source : Node_Access) return Node_Access;
    pragma Inline (Copy_Node);
 
-   function Copy_Tree (Source_Root : Node_Access) return Node_Access;
-
-   procedure Delete_Tree (X : in out Node_Access);
-
    procedure Insert_With_Hint
      (Dst_Tree : in out Tree_Type;
       Dst_Hint : Node_Access;
@@ -122,19 +106,28 @@ package body Ada.Containers.Ordered_Multisets is
    function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
    pragma Inline (Is_Less_Node_Node);
 
+   procedure Replace_Element
+     (Tree : in out Tree_Type;
+      Node : Node_Access;
+      Item : Element_Type);
+
    --------------------------
    -- Local Instantiations --
    --------------------------
 
+   procedure Free is
+     new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
    package Tree_Operations is
-     new Red_Black_Trees.Generic_Operations
-       (Tree_Types => Tree_Types,
-        Null_Node  => Node_Access'(null));
+     new Red_Black_Trees.Generic_Operations (Tree_Types);
 
-   use Tree_Operations;
+   procedure Delete_Tree is
+     new Tree_Operations.Generic_Delete_Tree (Free);
 
-   procedure Free is
-     new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+   function Copy_Tree is
+     new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
+
+   use Tree_Operations;
 
    function Is_Equal is
      new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
@@ -182,10 +175,6 @@ package body Ada.Containers.Ordered_Multisets is
 
    function "=" (Left, Right : Set) return Boolean is
    begin
-      if Left'Address = Right'Address then
-         return True;
-      end if;
-
       return Is_Equal (Left.Tree, Right.Tree);
    end "=";
 
@@ -216,24 +205,12 @@ package body Ada.Containers.Ordered_Multisets is
    -- Adjust --
    ------------
 
-   procedure Adjust (Container : in out Set) is
-      Tree : Tree_Type renames Container.Tree;
-
-      N : constant Count_Type := Tree.Length;
-      X : constant Node_Access := Tree.Root;
+   procedure Adjust is
+      new Tree_Operations.Generic_Adjust (Copy_Tree);
 
+   procedure Adjust (Container : in out Set) is
    begin
-      if N = 0 then
-         pragma Assert (X = null);
-         return;
-      end if;
-
-      Tree := (Length => 0, others => null);
-
-      Tree.Root := Copy_Tree (X);
-      Tree.First := Min (Tree.Root);
-      Tree.Last := Max (Tree.Root);
-      Tree.Length := N;
+      Adjust (Container.Tree);
    end Adjust;
 
    -------------
@@ -249,19 +226,19 @@ package body Ada.Containers.Ordered_Multisets is
          return No_Element;
       end if;
 
-      return Cursor'(Container'Unchecked_Access, Node);
+      return Cursor'(Container'Unrestricted_Access, Node);
    end Ceiling;
 
    -----------
    -- Clear --
    -----------
 
+   procedure Clear is
+      new Tree_Operations.Generic_Clear (Delete_Tree);
+
    procedure Clear (Container : in out Set) is
-      Tree : Tree_Type renames Container.Tree;
-      Root : Node_Access := Tree.Root;
    begin
-      Tree := (Length => 0, others => null);
-      Delete_Tree (Root);
+      Clear (Container.Tree);
    end Clear;
 
    -----------
@@ -297,49 +274,6 @@ package body Ada.Containers.Ordered_Multisets is
       return Target;
    end Copy_Node;
 
-   ---------------
-   -- Copy_Tree --
-   ---------------
-
-   function Copy_Tree (Source_Root : Node_Access) return Node_Access is
-      Target_Root : Node_Access := Copy_Node (Source_Root);
-
-      P, X : Node_Access;
-
-   begin
-      if Source_Root.Right /= null then
-         Target_Root.Right := Copy_Tree (Source_Root.Right);
-         Target_Root.Right.Parent := Target_Root;
-      end if;
-
-      P := Target_Root;
-      X := Source_Root.Left;
-      while X /= null loop
-         declare
-            Y : Node_Access := Copy_Node (X);
-
-         begin
-            P.Left := Y;
-            Y.Parent := P;
-
-            if X.Right /= null then
-               Y.Right := Copy_Tree (X.Right);
-               Y.Right.Parent := Y;
-            end if;
-
-            P := Y;
-            X := X.Left;
-         end;
-      end loop;
-
-      return Target_Root;
-
-   exception
-      when others =>
-         Delete_Tree (Target_Root);
-         raise;
-   end Copy_Tree;
-
    ------------
    -- Delete --
    ------------
@@ -367,11 +301,11 @@ package body Ada.Containers.Ordered_Multisets is
 
    procedure Delete (Container : in out Set; Position  : in out Cursor) is
    begin
-      if Position = No_Element then
-         return;
+      if Position.Node = null then
+         raise Constraint_Error;
       end if;
 
-      if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+      if Position.Container /= Container'Unrestricted_Access then
          raise Program_Error;
       end if;
 
@@ -415,48 +349,20 @@ package body Ada.Containers.Ordered_Multisets is
       Free (X);
    end Delete_Last;
 
-   -----------------
-   -- Delete_Tree --
-   -----------------
-
-   procedure Delete_Tree (X : in out Node_Access) is
-      Y : Node_Access;
-   begin
-      while X /= null loop
-         Y := X.Right;
-         Delete_Tree (Y);
-         Y := X.Left;
-         Free (X);
-         X := Y;
-      end loop;
-   end Delete_Tree;
-
    ----------------
    -- Difference --
    ----------------
 
    procedure Difference (Target : in out Set; Source : Set) is
    begin
-      if Target'Address = Source'Address then
-         Clear (Target);
-         return;
-      end if;
-
       Set_Ops.Difference (Target.Tree, Source.Tree);
    end Difference;
 
    function Difference (Left, Right : Set) return Set is
+      Tree : constant Tree_Type :=
+               Set_Ops.Difference (Left.Tree, Right.Tree);
    begin
-      if Left'Address = Right'Address then
-         return Empty_Set;
-      end if;
-
-      declare
-         Tree : constant Tree_Type :=
-                  Set_Ops.Difference (Left.Tree, Right.Tree);
-      begin
-         return (Controlled with Tree);
-      end;
+      return Set'(Controlled with Tree);
    end Difference;
 
    -------------
@@ -468,6 +374,39 @@ package body Ada.Containers.Ordered_Multisets is
       return Position.Node.Element;
    end Element;
 
+   ---------------------
+   -- Equivalent_Sets --
+   ---------------------
+
+   function Equivalent_Sets (Left, Right : Set) return Boolean is
+
+      function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
+      pragma Inline (Is_Equivalent_Node_Node);
+
+      function Is_Equivalent is
+        new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
+
+      -----------------------------
+      -- Is_Equivalent_Node_Node --
+      -----------------------------
+
+      function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
+      begin
+         if L.Element < R.Element then
+            return False;
+         elsif R.Element < L.Element then
+            return False;
+         else
+            return True;
+         end if;
+      end Is_Equivalent_Node_Node;
+
+   --  Start of processing for Equivalent_Sets
+
+   begin
+      return Is_Equivalent (Left.Tree, Right.Tree);
+   end Equivalent_Sets;
+
    -------------
    -- Exclude --
    -------------
@@ -499,7 +438,7 @@ package body Ada.Containers.Ordered_Multisets is
          return No_Element;
       end if;
 
-      return Cursor'(Container'Unchecked_Access, Node);
+      return Cursor'(Container'Unrestricted_Access, Node);
    end Find;
 
    -----------
@@ -512,7 +451,7 @@ package body Ada.Containers.Ordered_Multisets is
          return No_Element;
       end if;
 
-      return Cursor'(Container'Unchecked_Access, Container.Tree.First);
+      return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
    end First;
 
    -------------------
@@ -537,7 +476,7 @@ package body Ada.Containers.Ordered_Multisets is
          return No_Element;
       end if;
 
-      return Cursor'(Container'Unchecked_Access, Node);
+      return Cursor'(Container'Unrestricted_Access, Node);
    end Floor;
 
    ------------------
@@ -612,77 +551,9 @@ package body Ada.Containers.Ordered_Multisets is
             return No_Element;
          end if;
 
-         return Cursor'(Container'Unchecked_Access, Node);
+         return Cursor'(Container'Unrestricted_Access, Node);
       end Ceiling;
 
-      ----------------------------
-      -- Checked_Update_Element --
-      ----------------------------
-
-      procedure Checked_Update_Element
-        (Container : in out Set;
-         Position  : Cursor;
-         Process   : not null access procedure (Element : in out Element_Type))
-      is
-      begin
-         if Position.Container = null then
-            raise Constraint_Error;
-         end if;
-
-         if Position.Container /= Set_Access'(Container'Unchecked_Access) then
-            raise Program_Error;
-         end if;
-
-         declare
-            Old_Key : Key_Type renames Key (Position.Node.Element);
-
-         begin
-            Process (Position.Node.Element);
-
-            if Old_Key < Position.Node.Element
-              or else Old_Key > Position.Node.Element
-            then
-               null;
-            else
-               return;
-            end if;
-         end;
-
-         Delete_Node_Sans_Free (Container.Tree, Position.Node);
-
-         Do_Insert : declare
-            Result  : Node_Access;
-
-            function New_Node return Node_Access;
-            pragma Inline (New_Node);
-
-            procedure Insert_Post is
-              new Key_Keys.Generic_Insert_Post (New_Node);
-
-            procedure Insert is
-              new Key_Keys.Generic_Unconditional_Insert (Insert_Post);
-
-            --------------
-            -- New_Node --
-            --------------
-
-            function New_Node return Node_Access is
-            begin
-               return Position.Node;
-            end New_Node;
-
-         --  Start of processing for Do_Insert
-
-         begin
-            Insert
-              (Tree    => Container.Tree,
-               Key     => Key (Position.Node.Element),
-               Node    => Result);
-
-            pragma Assert (Result = Position.Node);
-         end Do_Insert;
-      end Checked_Update_Element;
-
       --------------
       -- Contains --
       --------------
@@ -759,7 +630,7 @@ package body Ada.Containers.Ordered_Multisets is
             return No_Element;
          end if;
 
-         return Cursor'(Container'Unchecked_Access, Node);
+         return Cursor'(Container'Unrestricted_Access, Node);
       end Find;
 
       -----------
@@ -775,7 +646,7 @@ package body Ada.Containers.Ordered_Multisets is
             return No_Element;
          end if;
 
-         return Cursor'(Container'Unchecked_Access, Node);
+         return Cursor'(Container'Unrestricted_Access, Node);
       end Floor;
 
       -------------------------
@@ -821,13 +692,26 @@ package body Ada.Containers.Ordered_Multisets is
 
          procedure Process_Node (Node : Node_Access) is
          begin
-            Process (Cursor'(Container'Unchecked_Access, Node));
+            Process (Cursor'(Container'Unrestricted_Access, Node));
          end Process_Node;
 
+         T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+         B : Natural renames T.Busy;
+
       --  Start of processing for Iterate
 
       begin
-         Local_Iterate (Container.Tree, Key);
+         B := B + 1;
+
+         begin
+            Local_Iterate (T, Key);
+         exception
+            when others =>
+               B := B - 1;
+               raise;
+         end;
+
+         B := B - 1;
       end Iterate;
 
       ---------
@@ -839,27 +723,6 @@ package body Ada.Containers.Ordered_Multisets is
          return Key (Position.Node.Element);
       end Key;
 
-      -------------
-      -- Replace --
-      -------------
-
-      --  In post-madision api:???
-
---    procedure Replace
---      (Container : in out Set;
---       Key       : Key_Type;
---       New_Item  : Element_Type)
---    is
---       Node : Node_Access := Key_Keys.Find (Container.Tree, Key);
-
---    begin
---       if Node = null then
---          raise Constraint_Error;
---       end if;
-
---       Replace_Node (Container, Node, New_Item);
---    end Replace;
-
       ---------------------
       -- Reverse_Iterate --
       ---------------------
@@ -881,15 +744,90 @@ package body Ada.Containers.Ordered_Multisets is
 
          procedure Process_Node (Node : Node_Access) is
          begin
-            Process (Cursor'(Container'Unchecked_Access, Node));
+            Process (Cursor'(Container'Unrestricted_Access, Node));
          end Process_Node;
 
+         T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+         B : Natural renames T.Busy;
+
       --  Start of processing for Reverse_Iterate
 
       begin
-         Local_Reverse_Iterate (Container.Tree, Key);
+         B := B + 1;
+
+         begin
+            Local_Reverse_Iterate (T, Key);
+         exception
+            when others =>
+               B := B - 1;
+               raise;
+         end;
+
+         B := B - 1;
       end Reverse_Iterate;
 
+      -----------------------------------
+      -- Update_Element_Preserving_Key --
+      -----------------------------------
+
+      procedure Update_Element_Preserving_Key
+        (Container : in out Set;
+         Position  : Cursor;
+         Process   : not null access procedure (Element : in out Element_Type))
+      is
+         Tree : Tree_Type renames Container.Tree;
+
+      begin
+         if Position.Node = null then
+            raise Constraint_Error;
+         end if;
+
+         if Position.Container /= Container'Unrestricted_Access then
+            raise Program_Error;
+         end if;
+
+         declare
+            E : Element_Type renames Position.Node.Element;
+            K : Key_Type renames Key (E);
+
+            B : Natural renames Tree.Busy;
+            L : Natural renames Tree.Lock;
+
+         begin
+            B := B + 1;
+            L := L + 1;
+
+            begin
+               Process (E);
+            exception
+               when others =>
+                  L := L - 1;
+                  B := B - 1;
+                  raise;
+            end;
+
+            L := L - 1;
+            B := B - 1;
+
+            if K < E
+              or else K > E
+            then
+               null;
+            else
+               return;
+            end if;
+         end;
+
+         declare
+            X : Node_Access := Position.Node;
+         begin
+            Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+            Free (X);
+         end;
+
+         raise Program_Error;
+      end Update_Element_Preserving_Key;
+
    end Generic_Keys;
 
    -----------------
@@ -948,7 +886,7 @@ package body Ada.Containers.Ordered_Multisets is
          New_Item,
          Position.Node);
 
-      Position.Container := Container'Unchecked_Access;
+      Position.Container := Container'Unrestricted_Access;
    end Insert;
 
    ----------------------
@@ -1006,25 +944,14 @@ package body Ada.Containers.Ordered_Multisets is
 
    procedure Intersection (Target : in out Set; Source : Set) is
    begin
-      if Target'Address = Source'Address then
-         return;
-      end if;
-
       Set_Ops.Intersection (Target.Tree, Source.Tree);
    end Intersection;
 
    function Intersection (Left, Right : Set) return Set is
+      Tree : constant Tree_Type :=
+               Set_Ops.Intersection (Left.Tree, Right.Tree);
    begin
-      if Left'Address = Right'Address then
-         return Left;
-      end if;
-
-      declare
-         Tree : constant Tree_Type :=
-                  Set_Ops.Intersection (Left.Tree, Right.Tree);
-      begin
-         return (Controlled with Tree);
-      end;
+      return Set'(Controlled with Tree);
    end Intersection;
 
    --------------
@@ -1086,10 +1013,6 @@ package body Ada.Containers.Ordered_Multisets is
 
    function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
    begin
-      if Subset'Address = Of_Set'Address then
-         return True;
-      end if;
-
       return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
    end Is_Subset;
 
@@ -1113,13 +1036,26 @@ package body Ada.Containers.Ordered_Multisets is
 
       procedure Process_Node (Node : Node_Access) is
       begin
-         Process (Cursor'(Container'Unchecked_Access, Node));
+         Process (Cursor'(Container'Unrestricted_Access, Node));
       end Process_Node;
 
+      T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+      B : Natural renames T.Busy;
+
    --  Start of processing for Iterate
 
    begin
-      Local_Iterate (Container.Tree);
+      B := B + 1;
+
+      begin
+         Local_Iterate (T);
+      exception
+         when others =>
+            B := B - 1;
+            raise;
+      end;
+
+      B := B - 1;
    end Iterate;
 
    procedure Iterate
@@ -1139,13 +1075,26 @@ package body Ada.Containers.Ordered_Multisets is
 
       procedure Process_Node (Node : Node_Access) is
       begin
-         Process (Cursor'(Container'Unchecked_Access, Node));
+         Process (Cursor'(Container'Unrestricted_Access, Node));
       end Process_Node;
 
+      T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+      B : Natural renames T.Busy;
+
    --  Start of processing for Iterate
 
    begin
-      Local_Iterate (Container.Tree, Item);
+      B := B + 1;
+
+      begin
+         Local_Iterate (T, Item);
+      exception
+         when others =>
+            B := B - 1;
+            raise;
+      end;
+
+      B := B - 1;
    end Iterate;
 
    ----------
@@ -1158,7 +1107,7 @@ package body Ada.Containers.Ordered_Multisets is
          return No_Element;
       end if;
 
-      return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
+      return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
    end Last;
 
    ------------------
@@ -1192,12 +1141,11 @@ package body Ada.Containers.Ordered_Multisets is
    -- Move --
    ----------
 
+   procedure Move is
+      new Tree_Operations.Generic_Move (Clear);
+
    procedure Move (Target : in out Set; Source : in out Set) is
    begin
-      if Target'Address = Source'Address then
-         return;
-      end if;
-
       Move (Target => Target.Tree, Source => Source.Tree);
    end Move;
 
@@ -1219,7 +1167,7 @@ package body Ada.Containers.Ordered_Multisets is
 
       declare
          Node : constant Node_Access :=
-           Tree_Operations.Next (Position.Node);
+                  Tree_Operations.Next (Position.Node);
       begin
          if Node = null then
             return No_Element;
@@ -1235,10 +1183,6 @@ package body Ada.Containers.Ordered_Multisets is
 
    function Overlap (Left, Right : Set) return Boolean is
    begin
-      if Left'Address = Right'Address then
-         return Left.Tree.Length /= 0;
-      end if;
-
       return Set_Ops.Overlap (Left.Tree, Right.Tree);
    end Overlap;
 
@@ -1269,7 +1213,7 @@ package body Ada.Containers.Ordered_Multisets is
 
       declare
          Node : constant Node_Access :=
-           Tree_Operations.Previous (Position.Node);
+                  Tree_Operations.Previous (Position.Node);
       begin
          if Node = null then
             return No_Element;
@@ -1287,8 +1231,29 @@ package body Ada.Containers.Ordered_Multisets is
      (Position : Cursor;
       Process  : not null access procedure (Element : Element_Type))
    is
+      E : Element_Type renames Position.Node.Element;
+
+      S : Set renames Position.Container.all;
+      T : Tree_Type renames S.Tree'Unrestricted_Access.all;
+
+      B : Natural renames T.Busy;
+      L : Natural renames T.Lock;
+
    begin
-      Process (Position.Node.Element);
+      B := B + 1;
+      L := L + 1;
+
+      begin
+         Process (E);
+      exception
+         when others =>
+            L := L - 1;
+            B := B - 1;
+            raise;
+      end;
+
+      L := L - 1;
+      B := B - 1;
    end Query_Element;
 
    ----------
@@ -1299,151 +1264,113 @@ package body Ada.Containers.Ordered_Multisets is
      (Stream    : access Root_Stream_Type'Class;
       Container : out Set)
    is
-      N : Count_Type'Base;
+      function Read_Node
+        (Stream : access Root_Stream_Type'Class) return Node_Access;
+      pragma Inline (Read_Node);
 
-      function New_Node return Node_Access;
-      pragma Inline (New_Node);
-
-      procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
+      procedure Read is
+         new Tree_Operations.Generic_Read (Clear, Read_Node);
 
-      --------------
-      -- New_Node --
-      --------------
+      ---------------
+      -- Read_Node --
+      ---------------
 
-      function New_Node return Node_Access is
+      function Read_Node
+        (Stream : access Root_Stream_Type'Class) return Node_Access
+      is
          Node : Node_Access := new Node_Type;
-
       begin
-         begin
-            Element_Type'Read (Stream, Node.Element);
-
-         exception
-            when others =>
-               Free (Node);
-               raise;
-         end;
-
+         Element_Type'Read (Stream, Node.Element);
          return Node;
-      end New_Node;
+      exception
+         when others =>
+            Free (Node);  --  Note that Free deallocates elem too
+            raise;
+      end Read_Node;
 
    --  Start of processing for Read
 
    begin
-      Clear (Container);
+      Read (Stream, Container.Tree);
+   end Read;
 
-      Count_Type'Base'Read (Stream, N);
-      pragma Assert (N >= 0);
+   ---------------------
+   -- Replace_Element --
+   ---------------------
 
-      Local_Read (Container.Tree, N);
-   end Read;
+   procedure Replace_Element
+     (Tree : in out Tree_Type;
+      Node : Node_Access;
+      Item : Element_Type)
+   is
+   begin
+      if Item < Node.Element
+        or else Node.Element < Item
+      then
+         null;
+      else
+         if Tree.Lock > 0 then
+            raise Program_Error;
+         end if;
 
-   -------------
-   -- Replace --
-   -------------
+         Node.Element := Item;
+         return;
+      end if;
 
-   --  NOTE: from post-madison api ???
+      Tree_Operations.Delete_Node_Sans_Free (Tree, Node);  -- Checks busy-bit
 
---   procedure Replace
---     (Container : in out Set;
---      Position  : Cursor;
---      By        : Element_Type)
---   is
---   begin
---      if Position.Container = null then
---         raise Constraint_Error;
---      end if;
+      Insert_New_Item : declare
+         function New_Node return Node_Access;
+         pragma Inline (New_Node);
 
---      if Position.Container /= Set_Access'(Container'Unchecked_Access) then
---         raise Program_Error;
---      end if;
+         procedure Insert_Post is
+            new Element_Keys.Generic_Insert_Post (New_Node);
 
---      Replace_Node (Container, Position.Node, By);
---   end Replace;
+         procedure Unconditional_Insert is
+            new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
 
-   ------------------
-   -- Replace_Node --
-   ------------------
+         --------------
+         -- New_Node --
+         --------------
+
+         function New_Node return Node_Access is
+         begin
+            Node.Element := Item;
+            return Node;
+         end New_Node;
+
+         Result : Node_Access;
+
+      --  Start of processing for Insert_New_Item
+
+      begin
+         Unconditional_Insert
+           (Tree => Tree,
+            Key  => Item,
+            Node => Result);
+
+         pragma Assert (Result = Node);
+      end Insert_New_Item;
+   end Replace_Element;
+
+   procedure Replace_Element
+     (Container : Set;
+      Position  : Cursor;
+      By        : Element_Type)
+   is
+      Tree : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+
+   begin
+      if Position.Node = null then
+         raise Constraint_Error;
+      end if;
 
-   --  NOTE: from post-madison api ???
-
---   procedure Replace_Node
---     (Container : in out Set;
---      Position  : Node_Access;
---      By        : Element_Type)
---   is
---      Tree : Tree_Type renames Container.Tree;
---      Node : Node_Access := Position;
-
---   begin
---      if By < Node.Element
---        or else Node.Element < By
---      then
---         null;
-
---      else
---         begin
---            Node.Element := By;
-
---         exception
---            when others =>
---               Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
---               Free (Node);
---               raise;
---         end;
-
---         return;
---      end if;
-
---      Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
-
---      begin
---         Node.Element := By;
-
---      exception
---         when others =>
---            Free (Node);
---            raise;
---      end;
---
---      Do_Insert : declare
---         Result  : Node_Access;
---         Success : Boolean;
-
---         function New_Node return Node_Access;
---         pragma Inline (New_Node);
-
---         procedure Insert_Post is
---           new Element_Keys.Generic_Insert_Post (New_Node);
---
---         procedure Insert is
---           new Element_Keys.Generic_Conditional_Insert (Insert_Post);
-
---         --------------
---         -- New_Node --
---         --------------
-
---         function New_Node return Node_Access is
---         begin
---            return Node;
---         end New_Node;
-
---      --  Start of processing for Do_Insert
-
---      begin
---         Insert
---           (Tree    => Tree,
---            Key     => Node.Element,
---            Node    => Result,
---            Success => Success);
---
---         if not Success then
---            Free (Node);
---            raise Program_Error;
---         end if;
---
---         pragma Assert (Result = Node);
---      end Do_Insert;
---   end Replace_Node;
+      if Position.Container /= Container'Unrestricted_Access then
+         raise Program_Error;
+      end if;
+
+      Replace_Element (Tree, Position.Node, By);
+   end Replace_Element;
 
    ---------------------
    -- Reverse_Iterate --
@@ -1465,13 +1392,26 @@ package body Ada.Containers.Ordered_Multisets is
 
       procedure Process_Node (Node : Node_Access) is
       begin
-         Process (Cursor'(Container'Unchecked_Access, Node));
+         Process (Cursor'(Container'Unrestricted_Access, Node));
       end Process_Node;
 
+      T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+      B : Natural renames T.Busy;
+
    --  Start of processing for Reverse_Iterate
 
    begin
-      Local_Reverse_Iterate (Container.Tree);
+      B := B + 1;
+
+      begin
+         Local_Reverse_Iterate (T);
+      exception
+         when others =>
+            B := B - 1;
+            raise;
+      end;
+
+      B := B - 1;
    end Reverse_Iterate;
 
    procedure Reverse_Iterate
@@ -1491,13 +1431,26 @@ package body Ada.Containers.Ordered_Multisets is
 
       procedure Process_Node (Node : Node_Access) is
       begin
-         Process (Cursor'(Container'Unchecked_Access, Node));
+         Process (Cursor'(Container'Unrestricted_Access, Node));
       end Process_Node;
 
+      T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+      B : Natural renames T.Busy;
+
    --  Start of processing for Reverse_Iterate
 
    begin
-      Local_Reverse_Iterate (Container.Tree, Item);
+      B := B + 1;
+
+      begin
+         Local_Reverse_Iterate (T, Item);
+      exception
+         when others =>
+            B := B - 1;
+            raise;
+      end;
+
+      B := B - 1;
    end Reverse_Iterate;
 
    -----------
@@ -1551,26 +1504,14 @@ package body Ada.Containers.Ordered_Multisets is
 
    procedure Symmetric_Difference (Target : in out Set; Source : Set) is
    begin
-      if Target'Address = Source'Address then
-         Clear (Target);
-         return;
-      end if;
-
       Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
    end Symmetric_Difference;
 
    function Symmetric_Difference (Left, Right : Set) return Set is
+      Tree : constant Tree_Type :=
+               Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
    begin
-      if Left'Address = Right'Address then
-         return Empty_Set;
-      end if;
-
-      declare
-         Tree : constant Tree_Type :=
-                  Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
-      begin
-         return (Controlled with Tree);
-      end;
+      return Set'(Controlled with Tree);
    end Symmetric_Difference;
 
    -----------
@@ -1579,25 +1520,14 @@ package body Ada.Containers.Ordered_Multisets is
 
    procedure Union (Target : in out Set; Source : Set) is
    begin
-      if Target'Address = Source'Address then
-         return;
-      end if;
-
       Set_Ops.Union (Target.Tree, Source.Tree);
    end Union;
 
    function Union (Left, Right : Set) return Set is
+      Tree : constant Tree_Type :=
+               Set_Ops.Union (Left.Tree, Right.Tree);
    begin
-      if Left'Address = Right'Address then
-         return Left;
-      end if;
-
-      declare
-         Tree : constant Tree_Type :=
-                  Set_Ops.Union (Left.Tree, Right.Tree);
-      begin
-         return (Controlled with Tree);
-      end;
+      return Set'(Controlled with Tree);
    end Union;
 
    -----------
@@ -1608,28 +1538,30 @@ package body Ada.Containers.Ordered_Multisets is
      (Stream    : access Root_Stream_Type'Class;
       Container : Set)
    is
-      procedure Process (Node : Node_Access);
-      pragma Inline (Process);
+      procedure Write_Node
+        (Stream : access Root_Stream_Type'Class;
+         Node   : Node_Access);
+      pragma Inline (Write_Node);
 
-      procedure Iterate is
-        new Tree_Operations.Generic_Iteration (Process);
+      procedure Write is
+         new Tree_Operations.Generic_Write (Write_Node);
 
-      -------------
-      -- Process --
-      -------------
+      ----------------
+      -- Write_Node --
+      ----------------
 
-      procedure Process (Node : Node_Access) is
+      procedure Write_Node
+        (Stream : access Root_Stream_Type'Class;
+         Node   : Node_Access)
+      is
       begin
          Element_Type'Write (Stream, Node.Element);
-      end Process;
+      end Write_Node;
 
    --  Start of processing for Write
 
    begin
-      Count_Type'Base'Write (Stream, Container.Tree.Length);
-      Iterate (Container.Tree);
+      Write (Stream, Container.Tree);
    end Write;
 
 end Ada.Containers.Ordered_Multisets;
-
-