From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/a-rbtgso.adb | 630 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 630 insertions(+) create mode 100644 gcc/ada/a-rbtgso.adb (limited to 'gcc/ada/a-rbtgso.adb') diff --git a/gcc/ada/a-rbtgso.adb b/gcc/ada/a-rbtgso.adb new file mode 100644 index 000000000..2b9b54024 --- /dev/null +++ b/gcc/ada/a-rbtgso.adb @@ -0,0 +1,630 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2009, 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 -- +-- . -- +-- -- +-- 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 + Tgt : Node_Access := Target.First; + Src : Node_Access := Source.First; + + 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; + + loop + if Tgt = null then + return; + end if; + + if Src = null then + return; + end if; + + if Is_Less (Tgt, Src) then + Tgt := Tree_Operations.Next (Tgt); + + elsif Is_Less (Src, Tgt) 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 + Tree : Tree_Type; + + L_Node : Node_Access := Left.First; + R_Node : Node_Access := Right.First; + + Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); + + begin + if Left'Address = Right'Address then + return Tree; -- Empty set + end if; + + if Left.Length = 0 then + return Tree; -- Empty set + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + loop + if L_Node = null then + return Tree; + 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; + + return Tree; + 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; + + exception + when others => + Delete_Tree (Tree.Root); + raise; + end Difference; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection + (Target : in out Tree_Type; + Source : Tree_Type) + is + Tgt : Node_Access := Target.First; + Src : Node_Access := Source.First; + + 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; + + while Tgt /= null + and then Src /= null + loop + if Is_Less (Tgt, Src) then + declare + X : Node_Access := Tgt; + begin + Tgt := Tree_Operations.Next (Tgt); + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + + elsif Is_Less (Src, Tgt) 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 + Tree : Tree_Type; + + L_Node : Node_Access := Left.First; + R_Node : Node_Access := Right.First; + + Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); + + begin + if Left'Address = Right'Address then + return Copy (Left); + end if; + + loop + if L_Node = null then + return Tree; + end if; + + if R_Node = null then + return Tree; + 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; + + exception + when others => + Delete_Tree (Tree.Root); + raise; + 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; + + declare + Subset_Node : Node_Access := Subset.First; + Set_Node : Node_Access := Of_Set.First; + + begin + 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 + L_Node : Node_Access := Left.First; + R_Node : Node_Access := Right.First; + + begin + if Left'Address = Right'Address then + return Left.Length /= 0; + end if; + + 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 Overlap; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference + (Target : in out Tree_Type; + Source : Tree_Type) + is + Tgt : Node_Access := Target.First; + Src : Node_Access := Source.First; + + New_Tgt_Node : Node_Access; + pragma Warnings (Off, New_Tgt_Node); + + begin + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + 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; + + if Is_Less (Tgt, Src) then + Tgt := Tree_Operations.Next (Tgt); + + elsif Is_Less (Src, Tgt) 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 + Tree : Tree_Type; + + L_Node : Node_Access := Left.First; + R_Node : Node_Access := Right.First; + + Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); + + begin + if Left'Address = Right'Address then + return Tree; -- Empty set + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + if Left.Length = 0 then + return Copy (Right); + end if; + + 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; + + return Tree; + 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; + + return Tree; + 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; + + exception + when others => + Delete_Tree (Tree.Root); + raise; + 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, + Src_Node => Node, + Dst_Node => Hint); + end Process; + + -- Start of processing for Union + + 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; + + Iterate (Source); + 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 + 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, + 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; -- cgit v1.2.3