diff options
Diffstat (limited to 'gcc-4.9/gcc/ada/a-rbtgso.adb')
-rw-r--r-- | gcc-4.9/gcc/ada/a-rbtgso.adb | 983 |
1 files changed, 983 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/a-rbtgso.adb b/gcc-4.9/gcc/ada/a-rbtgso.adb new file mode 100644 index 000000000..06a78e922 --- /dev/null +++ b/gcc-4.9/gcc/ada/a-rbtgso.adb @@ -0,0 +1,983 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; + +package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Clear (Tree : in out Tree_Type); + + function Copy (Source : Tree_Type) return Tree_Type; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Tree : in out Tree_Type) is + pragma Assert (Tree.Busy = 0); + pragma Assert (Tree.Lock = 0); + + Root : Node_Access := Tree.Root; + pragma Warnings (Off, Root); + + begin + Tree.Root := null; + Tree.First := null; + Tree.Last := null; + Tree.Length := 0; + + Delete_Tree (Root); + end Clear; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Tree_Type) return Tree_Type is + Target : Tree_Type; + + begin + if Source.Length = 0 then + return Target; + end if; + + Target.Root := Copy_Tree (Source.Root); + Target.First := Tree_Operations.Min (Target.Root); + Target.Last := Tree_Operations.Max (Target.Root); + Target.Length := Source.Length; + + return Target; + end Copy; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is + BT : Natural renames Target.Busy; + LT : Natural renames Target.Lock; + + BS : Natural renames Source'Unrestricted_Access.Busy; + LS : Natural renames Source'Unrestricted_Access.Lock; + + Tgt : Node_Access; + Src : Node_Access; + + Compare : Integer; + + begin + if Target'Address = Source'Address then + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Clear (Target); + return; + end if; + + if Source.Length = 0 then + return; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Tgt := Target.First; + Src := Source.First; + loop + if Tgt = null then + exit; + end if; + + if Src = null then + exit; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + begin + BT := BT + 1; + LT := LT + 1; + + BS := BS + 1; + LS := LS + 1; + + if Is_Less (Tgt, Src) then + Compare := -1; + elsif Is_Less (Src, Tgt) then + Compare := 1; + else + Compare := 0; + end if; + + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + + exception + when others => + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + + raise; + end; + + if Compare < 0 then + Tgt := Tree_Operations.Next (Tgt); + + elsif Compare > 0 then + Src := Tree_Operations.Next (Src); + + else + declare + X : Node_Access := Tgt; + begin + Tgt := Tree_Operations.Next (Tgt); + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + + Src := Tree_Operations.Next (Src); + end if; + end loop; + end Difference; + + function Difference (Left, Right : Tree_Type) return Tree_Type is + begin + if Left'Address = Right'Address then + return Tree_Type'(others => <>); -- Empty set + end if; + + if Left.Length = 0 then + return Tree_Type'(others => <>); -- Empty set + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + Tree : Tree_Type; + + L_Node : Node_Access; + R_Node : Node_Access; + + Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); + + begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = null then + exit; + end if; + + if R_Node = null then + while L_Node /= null loop + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + end loop; + + exit; + end if; + + if Is_Less (L_Node, R_Node) then + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + + elsif Is_Less (R_Node, L_Node) then + R_Node := Tree_Operations.Next (R_Node); + + else + L_Node := Tree_Operations.Next (L_Node); + R_Node := Tree_Operations.Next (R_Node); + end if; + end loop; + + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Tree; + + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + Delete_Tree (Tree.Root); + raise; + end; + end Difference; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection + (Target : in out Tree_Type; + Source : Tree_Type) + is + BT : Natural renames Target.Busy; + LT : Natural renames Target.Lock; + + BS : Natural renames Source'Unrestricted_Access.Busy; + LS : Natural renames Source'Unrestricted_Access.Lock; + + Tgt : Node_Access; + Src : Node_Access; + + Compare : Integer; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + if Source.Length = 0 then + Clear (Target); + return; + end if; + + Tgt := Target.First; + Src := Source.First; + while Tgt /= null + and then Src /= null + loop + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + begin + BT := BT + 1; + LT := LT + 1; + + BS := BS + 1; + LS := LS + 1; + + if Is_Less (Tgt, Src) then + Compare := -1; + elsif Is_Less (Src, Tgt) then + Compare := 1; + else + Compare := 0; + end if; + + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + + exception + when others => + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + + raise; + end; + + if Compare < 0 then + declare + X : Node_Access := Tgt; + begin + Tgt := Tree_Operations.Next (Tgt); + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + + elsif Compare > 0 then + Src := Tree_Operations.Next (Src); + + else + Tgt := Tree_Operations.Next (Tgt); + Src := Tree_Operations.Next (Src); + end if; + end loop; + + while Tgt /= null loop + declare + X : Node_Access := Tgt; + begin + Tgt := Tree_Operations.Next (Tgt); + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + end loop; + end Intersection; + + function Intersection (Left, Right : Tree_Type) return Tree_Type is + begin + if Left'Address = Right'Address then + return Copy (Left); + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + Tree : Tree_Type; + + L_Node : Node_Access; + R_Node : Node_Access; + + Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); + + begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = null then + exit; + end if; + + if R_Node = null then + exit; + end if; + + if Is_Less (L_Node, R_Node) then + L_Node := Tree_Operations.Next (L_Node); + + elsif Is_Less (R_Node, L_Node) then + R_Node := Tree_Operations.Next (R_Node); + + else + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + R_Node := Tree_Operations.Next (R_Node); + end if; + end loop; + + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Tree; + + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + Delete_Tree (Tree.Root); + raise; + end; + end Intersection; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset + (Subset : Tree_Type; + Of_Set : Tree_Type) return Boolean + is + begin + if Subset'Address = Of_Set'Address then + return True; + end if; + + if Subset.Length > Of_Set.Length then + return False; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + BL : Natural renames Subset'Unrestricted_Access.Busy; + LL : Natural renames Subset'Unrestricted_Access.Lock; + + BR : Natural renames Of_Set'Unrestricted_Access.Busy; + LR : Natural renames Of_Set'Unrestricted_Access.Lock; + + Subset_Node : Node_Access; + Set_Node : Node_Access; + + Result : Boolean; + + begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + Subset_Node := Subset.First; + Set_Node := Of_Set.First; + loop + if Set_Node = null then + Result := Subset_Node = null; + exit; + end if; + + if Subset_Node = null then + Result := True; + exit; + end if; + + if Is_Less (Subset_Node, Set_Node) then + Result := False; + exit; + end if; + + if Is_Less (Set_Node, Subset_Node) then + Set_Node := Tree_Operations.Next (Set_Node); + else + Set_Node := Tree_Operations.Next (Set_Node); + Subset_Node := Tree_Operations.Next (Subset_Node); + end if; + end loop; + + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Result; + + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; + end; + end Is_Subset; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Tree_Type) return Boolean is + begin + if Left'Address = Right'Address then + return Left.Length /= 0; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + L_Node : Node_Access; + R_Node : Node_Access; + + Result : Boolean; + + begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = null + or else R_Node = null + then + Result := False; + exit; + end if; + + if Is_Less (L_Node, R_Node) then + L_Node := Tree_Operations.Next (L_Node); + + elsif Is_Less (R_Node, L_Node) then + R_Node := Tree_Operations.Next (R_Node); + + else + Result := True; + exit; + end if; + end loop; + + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Result; + + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; + end; + end Overlap; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference + (Target : in out Tree_Type; + Source : Tree_Type) + is + BT : Natural renames Target.Busy; + LT : Natural renames Target.Lock; + + BS : Natural renames Source'Unrestricted_Access.Busy; + LS : Natural renames Source'Unrestricted_Access.Lock; + + Tgt : Node_Access; + Src : Node_Access; + + New_Tgt_Node : Node_Access; + pragma Warnings (Off, New_Tgt_Node); + + Compare : Integer; + + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + Tgt := Target.First; + Src := Source.First; + loop + if Tgt = null then + while Src /= null loop + Insert_With_Hint + (Dst_Tree => Target, + Dst_Hint => null, + Src_Node => Src, + Dst_Node => New_Tgt_Node); + + Src := Tree_Operations.Next (Src); + end loop; + + return; + end if; + + if Src = null then + return; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + begin + BT := BT + 1; + LT := LT + 1; + + BS := BS + 1; + LS := LS + 1; + + if Is_Less (Tgt, Src) then + Compare := -1; + elsif Is_Less (Src, Tgt) then + Compare := 1; + else + Compare := 0; + end if; + + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + + exception + when others => + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + + raise; + end; + + if Compare < 0 then + Tgt := Tree_Operations.Next (Tgt); + + elsif Compare > 0 then + Insert_With_Hint + (Dst_Tree => Target, + Dst_Hint => Tgt, + Src_Node => Src, + Dst_Node => New_Tgt_Node); + + Src := Tree_Operations.Next (Src); + + else + declare + X : Node_Access := Tgt; + begin + Tgt := Tree_Operations.Next (Tgt); + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + + Src := Tree_Operations.Next (Src); + end if; + end loop; + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is + begin + if Left'Address = Right'Address then + return Tree_Type'(others => <>); -- Empty set + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + if Left.Length = 0 then + return Copy (Right); + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + Tree : Tree_Type; + + L_Node : Node_Access; + R_Node : Node_Access; + + Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); + + begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = null then + while R_Node /= null loop + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => R_Node, + Dst_Node => Dst_Node); + R_Node := Tree_Operations.Next (R_Node); + end loop; + + exit; + end if; + + if R_Node = null then + while L_Node /= null loop + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + end loop; + + exit; + end if; + + if Is_Less (L_Node, R_Node) then + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + + elsif Is_Less (R_Node, L_Node) then + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => R_Node, + Dst_Node => Dst_Node); + + R_Node := Tree_Operations.Next (R_Node); + + else + L_Node := Tree_Operations.Next (L_Node); + R_Node := Tree_Operations.Next (R_Node); + end if; + end loop; + + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Tree; + + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + Delete_Tree (Tree.Root); + raise; + end; + end Symmetric_Difference; + + ----------- + -- Union -- + ----------- + + procedure Union (Target : in out Tree_Type; Source : Tree_Type) is + Hint : Node_Access; + + procedure Process (Node : Node_Access); + pragma Inline (Process); + + procedure Iterate is new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Node_Access) is + begin + Insert_With_Hint + (Dst_Tree => Target, + Dst_Hint => Hint, -- use node most recently inserted as hint + Src_Node => Node, + Dst_Node => Hint); + end Process; + + -- Start of processing for Union + + begin + if Target'Address = Source'Address then + return; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + BS : Natural renames Source'Unrestricted_Access.Busy; + LS : Natural renames Source'Unrestricted_Access.Lock; + + begin + BS := BS + 1; + LS := LS + 1; + + Iterate (Source); + + BS := BS - 1; + LS := LS - 1; + + exception + when others => + BS := BS - 1; + LS := LS - 1; + + raise; + end; + end Union; + + function Union (Left, Right : Tree_Type) return Tree_Type is + begin + if Left'Address = Right'Address then + return Copy (Left); + end if; + + if Left.Length = 0 then + return Copy (Right); + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + Tree : Tree_Type := Copy (Left); + + Hint : Node_Access; + + procedure Process (Node : Node_Access); + pragma Inline (Process); + + procedure Iterate is + new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Node_Access) is + begin + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => Hint, -- use node most recently inserted as hint + Src_Node => Node, + Dst_Node => Hint); + end Process; + + -- Start of processing for Union + + begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + Iterate (Right); + + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Tree; + + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + Delete_Tree (Tree.Root); + raise; + end; + end Union; + +end Ada.Containers.Red_Black_Trees.Generic_Set_Operations; |