URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-rbtgso.adb] - Blame information for rev 706

Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                         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    --
-- <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
      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;

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-rbtgso.adb] - Blame information for rev 706

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT LIBRARY COMPONENTS --`
4			`-- --`
5			`-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 2004-2009, Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNAT is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 3, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. --`
17			`-- --`
18			`-- As a special exception under Section 7 of GPL version 3, you are granted --`
19			`-- additional permissions described in the GCC Runtime Library Exception, --`
20			`-- version 3.1, as published by the Free Software Foundation. --`
21			`-- --`
22			`-- You should have received a copy of the GNU General Public License and --`
23			`-- a copy of the GCC Runtime Library Exception along with this program; --`
24			`-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --`
25			`-- <http://www.gnu.org/licenses/>. --`
26			`-- --`
27			`-- This unit was originally developed by Matthew J Heaney. --`
28			`------------------------------------------------------------------------------`
29
30			`with System; use type System.Address;`
31
32			`package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is`
33
34			`-----------------------`
35			`-- Local Subprograms --`
36			`-----------------------`
37
38			`procedure Clear (Tree : in out Tree_Type);`
39
40			`function Copy (Source : Tree_Type) return Tree_Type;`
41
42			`-----------`
43			`-- Clear --`
44			`-----------`
45
46			`procedure Clear (Tree : in out Tree_Type) is`
47			`pragma Assert (Tree.Busy = 0);`
48			`pragma Assert (Tree.Lock = 0);`
49
50			`Root : Node_Access := Tree.Root;`
51			`pragma Warnings (Off, Root);`
52
53			`begin`
54			`Tree.Root := null;`
55			`Tree.First := null;`
56			`Tree.Last := null;`
57			`Tree.Length := 0;`
58
59			`Delete_Tree (Root);`
60			`end Clear;`
61
62			`----------`
63			`-- Copy --`
64			`----------`
65
66			`function Copy (Source : Tree_Type) return Tree_Type is`
67			`Target : Tree_Type;`
68
69			`begin`
70			`if Source.Length = 0 then`
71			`return Target;`
72			`end if;`
73
74			`Target.Root := Copy_Tree (Source.Root);`
75			`Target.First := Tree_Operations.Min (Target.Root);`
76			`Target.Last := Tree_Operations.Max (Target.Root);`
77			`Target.Length := Source.Length;`
78
79			`return Target;`
80			`end Copy;`
81
82			`----------------`
83			`-- Difference --`
84			`----------------`
85
86			`procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is`
87			`Tgt : Node_Access := Target.First;`
88			`Src : Node_Access := Source.First;`
89
90			`begin`
91			`if Target'Address = Source'Address then`
92			`if Target.Busy > 0 then`
93			`raise Program_Error with`
94			`"attempt to tamper with cursors (container is busy)";`
95			`end if;`
96
97			`Clear (Target);`
98			`return;`
99			`end if;`
100
101			`if Source.Length = 0 then`
102			`return;`
103			`end if;`
104
105			`if Target.Busy > 0 then`
106			`raise Program_Error with`
107			`"attempt to tamper with cursors (container is busy)";`
108			`end if;`
109
110			`loop`
111			`if Tgt = null then`
112			`return;`
113			`end if;`
114
115			`if Src = null then`
116			`return;`
117			`end if;`
118
119			`if Is_Less (Tgt, Src) then`
120			`Tgt := Tree_Operations.Next (Tgt);`
121
122			`elsif Is_Less (Src, Tgt) then`
123			`Src := Tree_Operations.Next (Src);`
124
125			`else`
126			`declare`
127			`X : Node_Access := Tgt;`
128			`begin`
129			`Tgt := Tree_Operations.Next (Tgt);`
130			`Tree_Operations.Delete_Node_Sans_Free (Target, X);`
131			`Free (X);`
132			`end;`
133
134			`Src := Tree_Operations.Next (Src);`
135			`end if;`
136			`end loop;`
137			`end Difference;`
138
139			`function Difference (Left, Right : Tree_Type) return Tree_Type is`
140			`Tree : Tree_Type;`
141
142			`L_Node : Node_Access := Left.First;`
143			`R_Node : Node_Access := Right.First;`
144
145			`Dst_Node : Node_Access;`
146			`pragma Warnings (Off, Dst_Node);`
147
148			`begin`
149			`if Left'Address = Right'Address then`
150			`return Tree; -- Empty set`
151			`end if;`
152
153			`if Left.Length = 0 then`
154			`return Tree; -- Empty set`
155			`end if;`
156
157			`if Right.Length = 0 then`
158			`return Copy (Left);`
159			`end if;`
160
161			`loop`
162			`if L_Node = null then`
163			`return Tree;`
164			`end if;`
165
166			`if R_Node = null then`
167			`while L_Node /= null loop`
168			`Insert_With_Hint`
169			`(Dst_Tree => Tree,`
170			`Dst_Hint => null,`
171			`Src_Node => L_Node,`
172			`Dst_Node => Dst_Node);`
173
174			`L_Node := Tree_Operations.Next (L_Node);`
175
176			`end loop;`
177
178			`return Tree;`
179			`end if;`
180
181			`if Is_Less (L_Node, R_Node) then`
182			`Insert_With_Hint`
183			`(Dst_Tree => Tree,`
184			`Dst_Hint => null,`
185			`Src_Node => L_Node,`
186			`Dst_Node => Dst_Node);`
187
188			`L_Node := Tree_Operations.Next (L_Node);`
189
190			`elsif Is_Less (R_Node, L_Node) then`
191			`R_Node := Tree_Operations.Next (R_Node);`
192
193			`else`
194			`L_Node := Tree_Operations.Next (L_Node);`
195			`R_Node := Tree_Operations.Next (R_Node);`
196			`end if;`
197			`end loop;`
198
199			`exception`
200			`when others =>`
201			`Delete_Tree (Tree.Root);`
202			`raise;`
203			`end Difference;`
204
205			`------------------`
206			`-- Intersection --`
207			`------------------`
208
209			`procedure Intersection`
210			`(Target : in out Tree_Type;`
211			`Source : Tree_Type)`
212			`is`
213			`Tgt : Node_Access := Target.First;`
214			`Src : Node_Access := Source.First;`
215
216			`begin`
217			`if Target'Address = Source'Address then`
218			`return;`
219			`end if;`
220
221			`if Target.Busy > 0 then`
222			`raise Program_Error with`
223			`"attempt to tamper with cursors (container is busy)";`
224			`end if;`
225
226			`if Source.Length = 0 then`
227			`Clear (Target);`
228			`return;`
229			`end if;`
230
231			`while Tgt /= null`
232			`and then Src /= null`
233			`loop`
234			`if Is_Less (Tgt, Src) then`
235			`declare`
236			`X : Node_Access := Tgt;`
237			`begin`
238			`Tgt := Tree_Operations.Next (Tgt);`
239			`Tree_Operations.Delete_Node_Sans_Free (Target, X);`
240			`Free (X);`
241			`end;`
242
243			`elsif Is_Less (Src, Tgt) then`
244			`Src := Tree_Operations.Next (Src);`
245
246			`else`
247			`Tgt := Tree_Operations.Next (Tgt);`
248			`Src := Tree_Operations.Next (Src);`
249			`end if;`
250			`end loop;`
251
252			`while Tgt /= null loop`
253			`declare`
254			`X : Node_Access := Tgt;`
255			`begin`
256			`Tgt := Tree_Operations.Next (Tgt);`
257			`Tree_Operations.Delete_Node_Sans_Free (Target, X);`
258			`Free (X);`
259			`end;`
260			`end loop;`
261			`end Intersection;`
262
263			`function Intersection (Left, Right : Tree_Type) return Tree_Type is`
264			`Tree : Tree_Type;`
265
266			`L_Node : Node_Access := Left.First;`
267			`R_Node : Node_Access := Right.First;`
268
269			`Dst_Node : Node_Access;`
270			`pragma Warnings (Off, Dst_Node);`
271
272			`begin`
273			`if Left'Address = Right'Address then`
274			`return Copy (Left);`
275			`end if;`
276
277			`loop`
278			`if L_Node = null then`
279			`return Tree;`
280			`end if;`
281
282			`if R_Node = null then`
283			`return Tree;`
284			`end if;`
285
286			`if Is_Less (L_Node, R_Node) then`
287			`L_Node := Tree_Operations.Next (L_Node);`
288
289			`elsif Is_Less (R_Node, L_Node) then`
290			`R_Node := Tree_Operations.Next (R_Node);`
291
292			`else`
293			`Insert_With_Hint`
294			`(Dst_Tree => Tree,`
295			`Dst_Hint => null,`
296			`Src_Node => L_Node,`
297			`Dst_Node => Dst_Node);`
298
299			`L_Node := Tree_Operations.Next (L_Node);`
300			`R_Node := Tree_Operations.Next (R_Node);`
301			`end if;`
302			`end loop;`
303
304			`exception`
305			`when others =>`
306			`Delete_Tree (Tree.Root);`
307			`raise;`
308			`end Intersection;`
309
310			`---------------`
311			`-- Is_Subset --`
312			`---------------`
313
314			`function Is_Subset`
315			`(Subset : Tree_Type;`
316			`Of_Set : Tree_Type) return Boolean`
317			`is`
318			`begin`
319			`if Subset'Address = Of_Set'Address then`
320			`return True;`
321			`end if;`
322
323			`if Subset.Length > Of_Set.Length then`
324			`return False;`
325			`end if;`
326
327			`declare`
328			`Subset_Node : Node_Access := Subset.First;`
329			`Set_Node : Node_Access := Of_Set.First;`
330
331			`begin`
332			`loop`
333			`if Set_Node = null then`
334			`return Subset_Node = null;`
335			`end if;`
336
337			`if Subset_Node = null then`
338			`return True;`
339			`end if;`
340
341			`if Is_Less (Subset_Node, Set_Node) then`
342			`return False;`
343			`end if;`
344
345			`if Is_Less (Set_Node, Subset_Node) then`
346			`Set_Node := Tree_Operations.Next (Set_Node);`
347			`else`
348			`Set_Node := Tree_Operations.Next (Set_Node);`
349			`Subset_Node := Tree_Operations.Next (Subset_Node);`
350			`end if;`
351			`end loop;`
352			`end;`
353			`end Is_Subset;`
354
355			`-------------`
356			`-- Overlap --`
357			`-------------`
358
359			`function Overlap (Left, Right : Tree_Type) return Boolean is`
360			`L_Node : Node_Access := Left.First;`
361			`R_Node : Node_Access := Right.First;`
362
363			`begin`
364			`if Left'Address = Right'Address then`
365			`return Left.Length /= 0;`
366			`end if;`
367
368			`loop`
369			`if L_Node = null`
370			`or else R_Node = null`
371			`then`
372			`return False;`
373			`end if;`
374
375			`if Is_Less (L_Node, R_Node) then`
376			`L_Node := Tree_Operations.Next (L_Node);`
377
378			`elsif Is_Less (R_Node, L_Node) then`
379			`R_Node := Tree_Operations.Next (R_Node);`
380
381			`else`
382			`return True;`
383			`end if;`
384			`end loop;`
385			`end Overlap;`
386
387			`--------------------------`
388			`-- Symmetric_Difference --`
389			`--------------------------`
390
391			`procedure Symmetric_Difference`
392			`(Target : in out Tree_Type;`
393			`Source : Tree_Type)`
394			`is`
395			`Tgt : Node_Access := Target.First;`
396			`Src : Node_Access := Source.First;`
397
398			`New_Tgt_Node : Node_Access;`
399			`pragma Warnings (Off, New_Tgt_Node);`
400
401			`begin`
402			`if Target.Busy > 0 then`
403			`raise Program_Error with`
404			`"attempt to tamper with cursors (container is busy)";`
405			`end if;`
406
407			`if Target'Address = Source'Address then`
408			`Clear (Target);`
409			`return;`
410			`end if;`
411
412			`loop`
413			`if Tgt = null then`
414			`while Src /= null loop`
415			`Insert_With_Hint`
416			`(Dst_Tree => Target,`
417			`Dst_Hint => null,`
418			`Src_Node => Src,`
419			`Dst_Node => New_Tgt_Node);`
420
421			`Src := Tree_Operations.Next (Src);`
422			`end loop;`
423
424			`return;`
425			`end if;`
426
427			`if Src = null then`
428			`return;`
429			`end if;`
430
431			`if Is_Less (Tgt, Src) then`
432			`Tgt := Tree_Operations.Next (Tgt);`
433
434			`elsif Is_Less (Src, Tgt) then`
435			`Insert_With_Hint`
436			`(Dst_Tree => Target,`
437			`Dst_Hint => Tgt,`
438			`Src_Node => Src,`
439			`Dst_Node => New_Tgt_Node);`
440
441			`Src := Tree_Operations.Next (Src);`
442
443			`else`
444			`declare`
445			`X : Node_Access := Tgt;`
446			`begin`
447			`Tgt := Tree_Operations.Next (Tgt);`
448			`Tree_Operations.Delete_Node_Sans_Free (Target, X);`
449			`Free (X);`
450			`end;`
451
452			`Src := Tree_Operations.Next (Src);`
453			`end if;`
454			`end loop;`
455			`end Symmetric_Difference;`
456
457			`function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is`
458			`Tree : Tree_Type;`
459
460			`L_Node : Node_Access := Left.First;`
461			`R_Node : Node_Access := Right.First;`
462
463			`Dst_Node : Node_Access;`
464			`pragma Warnings (Off, Dst_Node);`
465
466			`begin`
467			`if Left'Address = Right'Address then`
468			`return Tree; -- Empty set`
469			`end if;`
470
471			`if Right.Length = 0 then`
472			`return Copy (Left);`
473			`end if;`
474
475			`if Left.Length = 0 then`
476			`return Copy (Right);`
477			`end if;`
478
479			`loop`
480			`if L_Node = null then`
481			`while R_Node /= null loop`
482			`Insert_With_Hint`
483			`(Dst_Tree => Tree,`
484			`Dst_Hint => null,`
485			`Src_Node => R_Node,`
486			`Dst_Node => Dst_Node);`
487			`R_Node := Tree_Operations.Next (R_Node);`
488			`end loop;`
489
490			`return Tree;`
491			`end if;`
492
493			`if R_Node = null then`
494			`while L_Node /= null loop`
495			`Insert_With_Hint`
496			`(Dst_Tree => Tree,`
497			`Dst_Hint => null,`
498			`Src_Node => L_Node,`
499			`Dst_Node => Dst_Node);`
500
501			`L_Node := Tree_Operations.Next (L_Node);`
502			`end loop;`
503
504			`return Tree;`
505			`end if;`
506
507			`if Is_Less (L_Node, R_Node) then`
508			`Insert_With_Hint`
509			`(Dst_Tree => Tree,`
510			`Dst_Hint => null,`
511			`Src_Node => L_Node,`
512			`Dst_Node => Dst_Node);`
513
514			`L_Node := Tree_Operations.Next (L_Node);`
515
516			`elsif Is_Less (R_Node, L_Node) then`
517			`Insert_With_Hint`
518			`(Dst_Tree => Tree,`
519			`Dst_Hint => null,`
520			`Src_Node => R_Node,`
521			`Dst_Node => Dst_Node);`
522
523			`R_Node := Tree_Operations.Next (R_Node);`
524
525			`else`
526			`L_Node := Tree_Operations.Next (L_Node);`
527			`R_Node := Tree_Operations.Next (R_Node);`
528			`end if;`
529			`end loop;`
530
531			`exception`
532			`when others =>`
533			`Delete_Tree (Tree.Root);`
534			`raise;`
535			`end Symmetric_Difference;`
536
537			`-----------`
538			`-- Union --`
539			`-----------`
540
541			`procedure Union (Target : in out Tree_Type; Source : Tree_Type)`
542			`is`
543			`Hint : Node_Access;`
544
545			`procedure Process (Node : Node_Access);`
546			`pragma Inline (Process);`
547
548			`procedure Iterate is new Tree_Operations.Generic_Iteration (Process);`
549
550			`-------------`
551			`-- Process --`
552			`-------------`
553
554			`procedure Process (Node : Node_Access) is`
555			`begin`
556			`Insert_With_Hint`
557			`(Dst_Tree => Target,`
558			`Dst_Hint => Hint,`
559			`Src_Node => Node,`
560			`Dst_Node => Hint);`
561			`end Process;`
562
563			`-- Start of processing for Union`
564
565			`begin`
566			`if Target'Address = Source'Address then`
567			`return;`
568			`end if;`
569
570			`if Target.Busy > 0 then`
571			`raise Program_Error with`
572			`"attempt to tamper with cursors (container is busy)";`
573			`end if;`
574
575			`Iterate (Source);`
576			`end Union;`
577
578			`function Union (Left, Right : Tree_Type) return Tree_Type is`
579			`begin`
580			`if Left'Address = Right'Address then`
581			`return Copy (Left);`
582			`end if;`
583
584			`if Left.Length = 0 then`
585			`return Copy (Right);`
586			`end if;`
587
588			`if Right.Length = 0 then`
589			`return Copy (Left);`
590			`end if;`
591
592			`declare`
593			`Tree : Tree_Type := Copy (Left);`
594
595			`Hint : Node_Access;`
596
597			`procedure Process (Node : Node_Access);`
598			`pragma Inline (Process);`
599
600			`procedure Iterate is`
601			`new Tree_Operations.Generic_Iteration (Process);`
602
603			`-------------`
604			`-- Process --`
605			`-------------`
606
607			`procedure Process (Node : Node_Access) is`
608			`begin`
609			`Insert_With_Hint`
610			`(Dst_Tree => Tree,`
611			`Dst_Hint => Hint,`
612			`Src_Node => Node,`
613			`Dst_Node => Hint);`
614			`end Process;`
615
616			`-- Start of processing for Union`
617
618			`begin`
619			`Iterate (Right);`
620			`return Tree;`
621
622			`exception`
623			`when others =>`
624			`Delete_Tree (Tree.Root);`
625			`raise;`
626			`end;`
627
628			`end Union;`
629
630			`end Ada.Containers.Red_Black_Trees.Generic_Set_Operations;`