diff options
Diffstat (limited to 'gcc/ada/a-ciorse.adb')
| -rw-r--r-- | gcc/ada/a-ciorse.adb | 866 |
1 files changed, 424 insertions, 442 deletions
diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index 9cd5e14db36..0f9615cc028 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS -- +-- A D A . C O N T A I N E R S . -- +-- I N D E F I N I T E _ O R D E R E D _ 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,22 +45,8 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); with Ada.Unchecked_Deallocation; -with System; use type System.Address; - package body Ada.Containers.Indefinite_Ordered_Sets is - type Element_Access is access Element_Type; - - 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_Access; - end record; - ----------------------- -- Local Subprograms -- ----------------------- @@ -70,10 +57,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets 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 Free (X : in out Node_Access); procedure Insert_With_Hint @@ -101,6 +84,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Parent (Node : Node_Access) return Node_Access; pragma Inline (Parent); + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type); + function Right (Node : Node_Access) return Node_Access; pragma Inline (Right); @@ -124,9 +112,13 @@ package body Ada.Containers.Indefinite_Ordered_Sets is new Ada.Unchecked_Deallocation (Element_Type, Element_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); + + procedure Delete_Tree is + new Tree_Operations.Generic_Delete_Tree (Free); + + function Copy_Tree is + new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); use Tree_Operations; @@ -189,14 +181,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -- Start of processing for "=" begin - if Left'Address = Right'Address then - return True; - end if; - return Is_Equal (Left.Tree, Right.Tree); end "="; - --------- -- ">" -- --------- @@ -222,25 +209,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -- Adjust -- ------------ - procedure Adjust (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; + procedure Adjust is + new Tree_Operations.Generic_Adjust (Copy_Tree); + procedure Adjust (Container : in out Set) is begin - if Tree.Length = 0 then - pragma Assert (Tree.Root = null); - return; - end if; - - begin - Tree.Root := Copy_Tree (Tree.Root); - exception - when others => - Tree := (Length => 0, others => null); - raise; - end; - - Tree.First := Min (Tree.Root); - Tree.Last := Max (Tree.Root); + Adjust (Container.Tree); end Adjust; ------------- @@ -256,19 +230,19 @@ package body Ada.Containers.Indefinite_Ordered_Sets 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; ----------- @@ -295,6 +269,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Copy_Node (Source : Node_Access) return Node_Access is Element : Element_Access := new Element_Type'(Source.Element.all); + begin return new Node_Type'(Parent => null, Left => null, @@ -307,66 +282,22 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise; 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; - Delete_Node_Sans_Free (Container.Tree, Position.Node); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); Free (Position.Node); - Position.Container := null; end Delete; @@ -388,9 +319,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ------------------ procedure Delete_First (Container : in out Set) is - C : Cursor := First (Container); + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.First; + begin - Delete (Container, C); + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end if; end Delete_First; ----------------- @@ -398,26 +334,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ----------------- procedure Delete_Last (Container : in out Set) is - C : Cursor := Last (Container); - begin - Delete (Container, C); - end Delete_Last; - - ----------------- - -- Delete_Tree -- - ----------------- + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.Last; - 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; + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Tree, X); Free (X); - X := Y; - end loop; - end Delete_Tree; + end if; + end Delete_Last; ---------------- -- Difference -- @@ -425,26 +350,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is 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; ------------- @@ -456,6 +369,39 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return Position.Node.Element.all; 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.all < R.Element.all then + return False; + elsif R.Element.all < L.Element.all 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 -- ------------- @@ -463,9 +409,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Exclude (Container : in out Set; Item : Element_Type) is X : Node_Access := Element_Keys.Find (Container.Tree, Item); + begin if X /= null then - Delete_Node_Sans_Free (Container.Tree, X); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); Free (X); end if; end Exclude; @@ -483,7 +430,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; ----------- @@ -496,7 +443,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Tree.First); + return Cursor'(Container'Unrestricted_Access, Container.Tree.First); end First; ------------------- @@ -521,7 +468,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Floor; ---------- @@ -529,13 +476,25 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ---------- procedure Free (X : in out Node_Access) is + procedure Deallocate is new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + begin - if X /= null then - Free_Element (X.Element); - Deallocate (X); + if X = null then + return; end if; + + begin + Free_Element (X.Element); + exception + when others => + X.Element := null; + Deallocate (X); + raise; + end; + + Deallocate (X); end Free; ------------------ @@ -610,90 +569,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets 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.all); - - begin - Process (Position.Node.Element.all); - - if Old_Key < Position.Node.Element.all - or else Old_Key > Position.Node.Element.all - then - null; - else - return; - end if; - end; - - declare - Result : Node_Access; - Success : Boolean; - - 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_Conditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - begin - return Position.Node; - end New_Node; - - -- Start of processing for Checked_Update_Element - - begin - Delete_Node_Sans_Free (Container.Tree, Position.Node); - - Insert - (Tree => Container.Tree, - Key => Key (Position.Node.Element.all), - Node => Result, - Success => Success); - - if not Success then - declare - X : Node_Access := Position.Node; - begin - Free (X); - end; - - raise Program_Error; - end if; - - pragma Assert (Result = Position.Node); - end; - end Checked_Update_Element; - -------------- -- Contains -- -------------- @@ -715,7 +593,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise Constraint_Error; end if; - Delete_Node_Sans_Free (Container.Tree, X); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); Free (X); end Delete; @@ -724,9 +602,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ------------- function Element (Container : Set; Key : Key_Type) return Element_Type is - C : constant Cursor := Find (Container, Key); + Node : constant Node_Access := + Key_Keys.Find (Container.Tree, Key); + begin - return C.Node.Element.all; + return Node.Element.all; end Element; ------------- @@ -738,7 +618,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is begin if X /= null then - Delete_Node_Sans_Free (Container.Tree, X); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); Free (X); end if; end Exclude; @@ -756,7 +636,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; ----------- @@ -772,7 +652,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Floor; ------------------------- @@ -806,6 +686,88 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return Key (Position.Node.Element.all); end Key; + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if Node = null then + raise Constraint_Error; + end if; + + Replace_Element (Container.Tree, Node, New_Item); + end Replace; + + ----------------------------------- + -- 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.all; + 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; ----------------- @@ -831,6 +793,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then + if Container.Tree.Lock > 0 then + raise Program_Error; + end if; + X := Position.Node.Element; Position.Node.Element := new Element_Type'(New_Item); Free_Element (X); @@ -883,7 +849,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Position.Node, Inserted); - Position.Container := Container'Unchecked_Access; + Position.Container := Container'Unrestricted_Access; end Insert; procedure Insert (Container : in out Set; New_Item : Element_Type) is @@ -961,25 +927,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets 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; -------------- @@ -988,7 +943,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Is_Empty (Container : Set) return Boolean is begin - return Length (Container) = 0; + return Container.Tree.Length = 0; end Is_Empty; ----------------------------- @@ -1004,7 +959,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return Right.Element.all < Left; end Is_Greater_Element_Node; - -------------------------- -- Is_Less_Element_Node -- -------------------------- @@ -1031,10 +985,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets 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; @@ -1058,13 +1008,26 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - -- Start of processing for Iterate + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + + -- Start of prccessing 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; ---------- @@ -1077,7 +1040,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Tree.Last); + return Cursor'(Container'Unrestricted_Access, Container.Tree.Last); end Last; ------------------ @@ -1111,12 +1074,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets 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; @@ -1137,7 +1099,8 @@ package body Ada.Containers.Indefinite_Ordered_Sets is declare Node : constant Node_Access := - Tree_Operations.Next (Position.Node); + Tree_Operations.Next (Position.Node); + begin if Node = null then return No_Element; @@ -1153,10 +1116,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets 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; @@ -1186,7 +1145,8 @@ package body Ada.Containers.Indefinite_Ordered_Sets is declare Node : constant Node_Access := - Tree_Operations.Previous (Position.Node); + Tree_Operations.Previous (Position.Node); + begin if Node = null then return No_Element; @@ -1204,8 +1164,29 @@ package body Ada.Containers.Indefinite_Ordered_Sets is (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is + E : Element_Type renames Position.Node.Element.all; + + 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.all); + 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; ---------- @@ -1213,21 +1194,23 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ---------- procedure Read - (Stream : access Ada.Streams.Root_Stream_Type'Class; + (Stream : access Root_Stream_Type'Class; Container : out Set) is - N : Count_Type'Base; - - function New_Node return Node_Access; + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access; + pragma Inline (Read_Node); procedure Read is - new Tree_Operations.Generic_Read (New_Node); + 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 @@ -1236,17 +1219,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is exception when others => - Free (Node); + Free (Node); -- Note that Free deallocates elem too raise; - end New_Node; + end Read_Node; -- Start of processing for Read begin - Clear (Container); - Count_Type'Base'Read (Stream, N); - pragma Assert (N >= 0); - Read (Container.Tree, N); + Read (Stream, Container.Tree); end Read; ------------- @@ -1269,129 +1249,139 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Free_Element (X); end Replace; --- TODO ??? --- 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_Element (Container, Node, New_Item); --- end Replace; - --------------------- -- Replace_Element -- --------------------- --- TODO: ??? --- procedure Replace_Element --- (Container : in out Set; --- Position : Node_Access; --- By : Element_Type) --- is - --- Node : Node_Access := Position; - --- begin --- if By < Node.Element.all --- or else Node.Element.all < By --- then --- null; - --- else --- declare --- X : Element_Access := Node.Element; - --- begin --- Node.Element := new Element_Type'(By); - --- -- NOTE: If there's an exception here, then just --- -- let it propagate. We haven't modified the --- -- state of the container, so there's nothing else --- -- we need to do. - --- Free_Element (X); --- end; - --- return; --- end if; - --- Delete_Node_Sans_Free (Container.Tree, Node); - --- begin --- Free_Element (Node.Element); --- exception --- when others => --- Node.Element := null; -- don't attempt to dealloc X.E again --- Free (Node); --- raise; --- end; - --- begin --- Node.Element := new Element_Type'(By); --- exception --- when others => --- Free (Node); --- raise; --- end; - --- declare --- function New_Node return Node_Access; --- pragma Inline (New_Node); - --- function New_Node return Node_Access is --- begin --- return Node; --- end 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); - --- Result : Node_Access; --- Success : Boolean; - --- begin --- Insert --- (Tree => Container.Tree, --- Key => Node.Element.all, --- Node => Result, --- Success => Success); - --- if not Success then --- Free (Node); --- raise Program_Error; --- end if; - --- pragma Assert (Result = Node); --- end; --- end Replace_Element; - - --- procedure Replace_Element --- (Container : in out Set; --- Position : Cursor; --- By : 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; - --- Replace_Element (Container, Position.Node, By); --- end Replace_Element; + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type) + is + begin + if Item < Node.Element.all + or else Node.Element.all < Item + then + null; + else + if Tree.Lock > 0 then + raise Program_Error; + end if; + + declare + X : Element_Access := Node.Element; + begin + Node.Element := new Element_Type'(Item); + Free_Element (X); + end; + + return; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit + + Insert_New_Item : declare + 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 + Node.Element := new Element_Type'(Item); -- OK if fails + return Node; + end New_Node; + + Result : Node_Access; + Inserted : Boolean; + + X : Element_Access := Node.Element; + + -- Start of processing for Insert_New_Item + + begin + Attempt_Insert : begin + Insert + (Tree => Tree, + Key => Item, + Node => Result, + Success => Inserted); -- TODO: change name of formal param + exception + when others => + Inserted := False; + end Attempt_Insert; + + if Inserted then + pragma Assert (Result = Node); + Free_Element (X); -- OK if fails + return; + end if; + end Insert_New_Item; + + Reinsert_Old_Element : declare + 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; + + Result : Node_Access; + Inserted : Boolean; + + -- Start of processing for Reinsert_Old_Element + + begin + Insert + (Tree => Tree, + Key => Node.Element.all, + Node => Result, + Success => Inserted); -- TODO: change name of formal param + exception + when others => + null; + end Reinsert_Old_Element; + + raise Program_Error; + end Replace_Element; + + procedure Replace_Element + (Container : Set; + Position : Cursor; + By : Element_Type) + is + Tree : Tree_Type renames Position.Container.Tree'Unrestricted_Access.all; + + begin + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + Replace_Element (Tree, Position.Node, By); + end Replace_Element; --------------------- -- Reverse_Iterate -- @@ -1413,13 +1403,26 @@ package body Ada.Containers.Indefinite_Ordered_Sets 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; ----------- @@ -1473,26 +1476,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets 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; ----------- @@ -1501,25 +1492,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets 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; ----------- @@ -1527,31 +1507,33 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ----------- procedure Write - (Stream : access Ada.Streams.Root_Stream_Type'Class; + (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'Output (Stream, Node.Element.all); - 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.Indefinite_Ordered_Sets; - - |