diff options
author | Matthew Heaney <heaney@adacore.com> | 2005-06-16 10:56:24 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2005-06-16 10:56:24 +0200 |
commit | 8704d4b30e3eace58fc9506cf3533b15835c784a (patch) | |
tree | 60bbc3a40631ce4a825ff74330cd04720cf0d624 /gcc/ada/a-coorse.adb | |
parent | dc8f57914cb54a209cf2d52bb04d21502990842b (diff) | |
download | gcc-8704d4b30e3eace58fc9506cf3533b15835c784a.zip gcc-8704d4b30e3eace58fc9506cf3533b15835c784a.tar.gz gcc-8704d4b30e3eace58fc9506cf3533b15835c784a.tar.bz2 |
a-swunha.ads, [...]: Removed.
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.
From-SVN: r101069
Diffstat (limited to 'gcc/ada/a-coorse.adb')
-rw-r--r-- | gcc/ada/a-coorse.adb | 816 |
1 files changed, 390 insertions, 426 deletions
diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index 03cf003..6e80398 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.ORDERED_SETS -- +-- A D A . C O N T A I N E R S . 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,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_Sets 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; - ------------------------------ -- Access to Fields of Node -- ------------------------------ @@ -96,10 +84,6 @@ package body Ada.Containers.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 Insert_With_Hint (Dst_Tree : in out Tree_Type; Dst_Hint : Node_Access; @@ -122,19 +106,28 @@ package body Ada.Containers.Ordered_Sets 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); @@ -180,10 +173,6 @@ package body Ada.Containers.Ordered_Sets 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 "="; @@ -212,24 +201,12 @@ package body Ada.Containers.Ordered_Sets 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; ------------- @@ -245,19 +222,19 @@ package body Ada.Containers.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; ----------- @@ -296,65 +273,21 @@ package body Ada.Containers.Ordered_Sets 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 -- ------------ 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; @@ -367,7 +300,7 @@ package body Ada.Containers.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; @@ -376,9 +309,14 @@ package body Ada.Containers.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; ----------------- @@ -386,26 +324,15 @@ package body Ada.Containers.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 -- @@ -413,26 +340,14 @@ package body Ada.Containers.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; ------------- @@ -444,6 +359,38 @@ package body Ada.Containers.Ordered_Sets 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 -- ------------- @@ -453,7 +400,7 @@ package body Ada.Containers.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; @@ -471,7 +418,7 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; ----------- @@ -484,7 +431,7 @@ package body Ada.Containers.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; ------------------- @@ -509,7 +456,7 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Floor; ------------------ @@ -584,88 +531,9 @@ package body Ada.Containers.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); - - 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); - - declare - Result : Node_Access; - Success : Boolean; - - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Local_Insert_Post is - new Key_Keys.Generic_Insert_Post (New_Node); - - procedure Local_Conditional_Insert is - new Key_Keys.Generic_Conditional_Insert (Local_Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - begin - return Position.Node; - end New_Node; - - - begin - Local_Conditional_Insert - (Tree => Container.Tree, - Key => Key (Position.Node.Element), - 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 -- -------------- @@ -700,6 +568,7 @@ package body Ada.Containers.Ordered_Sets is Key : Key_Type) return Element_Type is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + begin return Node.Element; end Element; @@ -710,6 +579,7 @@ package body Ada.Containers.Ordered_Sets is procedure Exclude (Container : in out Set; Key : Key_Type) is X : Node_Access := Key_Keys.Find (Container.Tree, Key); + begin if X /= null then Delete_Node_Sans_Free (Container.Tree, X); @@ -729,7 +599,7 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; ----------- @@ -744,7 +614,7 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Floor; ------------------------- @@ -784,22 +654,82 @@ package body Ada.Containers.Ordered_Sets is -- Replace -- ------------- --- TODO??? + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); --- 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; --- begin --- if Node = null then --- raise Constraint_Error; --- end if; + Replace_Element (Container.Tree, Node, New_Item); + end Replace; --- Replace_Element (Container, 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; + 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; @@ -824,6 +754,10 @@ package body Ada.Containers.Ordered_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then + if Container.Tree.Lock > 0 then + raise Program_Error; + end if; + Position.Node.Element := New_Item; end if; end Include; @@ -871,14 +805,13 @@ package body Ada.Containers.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 - Position : Cursor; Inserted : Boolean; @@ -948,25 +881,14 @@ package body Ada.Containers.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; -------------- @@ -975,7 +897,7 @@ package body Ada.Containers.Ordered_Sets is function Is_Empty (Container : Set) return Boolean is begin - return Length (Container) = 0; + return Container.Tree.Length = 0; end Is_Empty; ------------------------ @@ -1028,10 +950,6 @@ package body Ada.Containers.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; @@ -1055,13 +973,26 @@ package body Ada.Containers.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 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; ---------- @@ -1074,7 +1005,7 @@ package body Ada.Containers.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; ------------------ @@ -1108,12 +1039,11 @@ package body Ada.Containers.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; @@ -1129,7 +1059,8 @@ package body Ada.Containers.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; @@ -1150,10 +1081,6 @@ package body Ada.Containers.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; @@ -1202,8 +1129,29 @@ package body Ada.Containers.Ordered_Sets 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; ---------- @@ -1214,42 +1162,36 @@ package body Ada.Containers.Ordered_Sets 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); + raise; + end Read_Node; -- Start of processing for Read begin - Clear (Container); - - Count_Type'Base'Read (Stream, N); - pragma Assert (N >= 0); - - Local_Read (Container.Tree, N); + Read (Stream, Container.Tree); end Read; ------------- @@ -1265,6 +1207,10 @@ package body Ada.Containers.Ordered_Sets is raise Constraint_Error; end if; + if Container.Tree.Lock > 0 then + raise Program_Error; + end if; + Node.Element := New_Item; end Replace; @@ -1272,95 +1218,124 @@ package body Ada.Containers.Ordered_Sets is -- 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 --- or else Node.Element < By --- then --- null; - --- else --- begin --- Node.Element := By; - --- exception --- when others => --- Delete_Node_Sans_Free (Container.Tree, Node); --- Free (Node); --- raise; --- end; - --- return; --- end if; - --- Delete_Node_Sans_Free (Container.Tree, Node); - --- begin --- Node.Element := 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, --- 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 + or else Node.Element < Item + then + null; + else + if Tree.Lock > 0 then + raise Program_Error; + end if; + + Node.Element := Item; + 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 := Item; + return Node; + end New_Node; + + Result : Node_Access; + Inserted : Boolean; + + -- Start of processing for Insert_New_Item + + begin + Insert + (Tree => Tree, + Key => Item, + Node => Result, + Success => Inserted); -- TODO: change param name + + if Inserted then + pragma Assert (Result = Node); + return; + end if; + exception + when others => + null; -- Assignment must have failed + 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, + Node => Result, + Success => Inserted); -- TODO: change param name + exception + when others => + null; -- Assignment must have failed + 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 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 -- @@ -1382,13 +1357,26 @@ package body Ada.Containers.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; ----------- @@ -1442,26 +1430,14 @@ package body Ada.Containers.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; ----------- @@ -1470,25 +1446,14 @@ package body Ada.Containers.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; ----------- @@ -1499,31 +1464,30 @@ package body Ada.Containers.Ordered_Sets 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_Sets; - - |