diff options
Diffstat (limited to 'gcc/ada/a-rbtgso.adb')
| -rw-r--r-- | gcc/ada/a-rbtgso.adb | 739 |
1 files changed, 0 insertions, 739 deletions
diff --git a/gcc/ada/a-rbtgso.adb b/gcc/ada/a-rbtgso.adb deleted file mode 100644 index f6daa90ff1d..00000000000 --- a/gcc/ada/a-rbtgso.adb +++ /dev/null @@ -1,739 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, 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 - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------- - -- 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 - use type Helpers.Tamper_Counts; - pragma Assert (Tree.TC = (Busy => 0, 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 - Tgt : Node_Access; - Src : Node_Access; - - Compare : Integer; - - begin - if Target'Address = Source'Address then - TC_Check (Target.TC); - - Clear (Target); - return; - end if; - - if Source.Length = 0 then - return; - end if; - - TC_Check (Target.TC); - - 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. - - declare - Lock_Target : With_Lock (Target.TC'Unrestricted_Access); - Lock_Source : With_Lock (Source.TC'Unrestricted_Access); - begin - if Is_Less (Tgt, Src) then - Compare := -1; - elsif Is_Less (Src, Tgt) then - Compare := 1; - else - Compare := 0; - end if; - 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 - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - Tree : Tree_Type; - - L_Node : Node_Access; - R_Node : Node_Access; - - Dst_Node : Node_Access; - pragma Warnings (Off, Dst_Node); - - begin - 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; - - return Tree; - - exception - when others => - Delete_Tree (Tree.Root); - raise; - end; - end Difference; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection - (Target : in out Tree_Type; - Source : Tree_Type) - is - Tgt : Node_Access; - Src : Node_Access; - - Compare : Integer; - - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Target.TC); - - 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. - - declare - Lock_Target : With_Lock (Target.TC'Unrestricted_Access); - Lock_Source : With_Lock (Source.TC'Unrestricted_Access); - begin - if Is_Less (Tgt, Src) then - Compare := -1; - elsif Is_Less (Src, Tgt) then - Compare := 1; - else - Compare := 0; - end if; - 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 - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - Tree : Tree_Type; - - L_Node : Node_Access; - R_Node : Node_Access; - - Dst_Node : Node_Access; - pragma Warnings (Off, Dst_Node); - - begin - 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; - - return Tree; - - exception - when others => - 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 - Lock_Subset : With_Lock (Subset.TC'Unrestricted_Access); - Lock_Of_Set : With_Lock (Of_Set.TC'Unrestricted_Access); - - Subset_Node : Node_Access; - Set_Node : Node_Access; - - begin - Subset_Node := Subset.First; - Set_Node := Of_Set.First; - loop - if Set_Node = null then - return Subset_Node = null; - end if; - - if Subset_Node = null then - return True; - end if; - - if Is_Less (Subset_Node, Set_Node) then - return False; - 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; - 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 - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - L_Node : Node_Access; - R_Node : Node_Access; - begin - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = null - or else R_Node = null - then - return False; - 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 - return True; - end if; - end loop; - end; - end Overlap; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference - (Target : in out Tree_Type; - Source : Tree_Type) - is - 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. - - declare - Lock_Target : With_Lock (Target.TC'Unrestricted_Access); - Lock_Source : With_Lock (Source.TC'Unrestricted_Access); - begin - if Is_Less (Tgt, Src) then - Compare := -1; - elsif Is_Less (Src, Tgt) then - Compare := 1; - else - Compare := 0; - end if; - 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 - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - Tree : Tree_Type; - - L_Node : Node_Access; - R_Node : Node_Access; - - Dst_Node : Node_Access; - pragma Warnings (Off, Dst_Node); - - begin - 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; - - return Tree; - - exception - when others => - 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 - Lock_Source : With_Lock (Source.TC'Unrestricted_Access); - begin - Iterate (Source); - 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 - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - 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 - Iterate (Right); - return Tree; - - exception - when others => - Delete_Tree (Tree.Root); - raise; - end; - end Union; - -end Ada.Containers.Red_Black_Trees.Generic_Set_Operations; |