-- --
-- 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 --
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 --
-----------------------------
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;
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);
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 "=";
-- 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;
-------------
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;
-----------
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 --
------------
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;
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;
-------------
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 --
-------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Find;
-----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.Tree.First);
+ return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
end First;
-------------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Floor;
------------------
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 --
--------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Find;
-----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Floor;
-------------------------
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;
---------
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 --
---------------------
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;
-----------------
New_Item,
Position.Node);
- Position.Container := Container'Unchecked_Access;
+ Position.Container := Container'Unrestricted_Access;
end Insert;
----------------------
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;
--------------
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;
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
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;
----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
+ return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
end Last;
------------------
-- 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;
declare
Node : constant Node_Access :=
- Tree_Operations.Next (Position.Node);
+ Tree_Operations.Next (Position.Node);
begin
if Node = null then
return No_Element;
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;
declare
Node : constant Node_Access :=
- Tree_Operations.Previous (Position.Node);
+ Tree_Operations.Previous (Position.Node);
begin
if Node = null then
return No_Element;
(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;
----------
(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 --
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
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;
-----------
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;
-----------
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;
-----------
(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;
-
-