1------------------------------------------------------------------------------
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-2018, 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
30with System; use type System.Address;
31
32package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
33
34   pragma Warnings (Off, "variable ""Busy*"" is not referenced");
35   pragma Warnings (Off, "variable ""Lock*"" is not referenced");
36   --  See comment in Ada.Containers.Helpers
37
38   -----------------------
39   -- Local Subprograms --
40   -----------------------
41
42   procedure Clear (Tree : in out Tree_Type);
43
44   function Copy (Source : Tree_Type) return Tree_Type;
45
46   -----------
47   -- Clear --
48   -----------
49
50   procedure Clear (Tree : in out Tree_Type) is
51      use type Helpers.Tamper_Counts;
52      pragma Assert (Tree.TC = (Busy => 0, Lock => 0));
53
54      Root : Node_Access := Tree.Root;
55      pragma Warnings (Off, Root);
56
57   begin
58      Tree.Root := null;
59      Tree.First := null;
60      Tree.Last := null;
61      Tree.Length := 0;
62
63      Delete_Tree (Root);
64   end Clear;
65
66   ----------
67   -- Copy --
68   ----------
69
70   function Copy (Source : Tree_Type) return Tree_Type is
71      Target : Tree_Type;
72
73   begin
74      if Source.Length = 0 then
75         return Target;
76      end if;
77
78      Target.Root := Copy_Tree (Source.Root);
79      Target.First := Tree_Operations.Min (Target.Root);
80      Target.Last := Tree_Operations.Max (Target.Root);
81      Target.Length := Source.Length;
82
83      return Target;
84   end Copy;
85
86   ----------------
87   -- Difference --
88   ----------------
89
90   procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is
91      Tgt : Node_Access;
92      Src : Node_Access;
93
94      Compare : Integer;
95
96   begin
97      if Target'Address = Source'Address then
98         TC_Check (Target.TC);
99
100         Clear (Target);
101         return;
102      end if;
103
104      if Source.Length = 0 then
105         return;
106      end if;
107
108      TC_Check (Target.TC);
109
110      Tgt := Target.First;
111      Src := Source.First;
112      loop
113         if Tgt = null then
114            exit;
115         end if;
116
117         if Src = null then
118            exit;
119         end if;
120
121         --  Per AI05-0022, the container implementation is required to detect
122         --  element tampering by a generic actual subprogram.
123
124         declare
125            Lock_Target : With_Lock (Target.TC'Unrestricted_Access);
126            Lock_Source : With_Lock (Source.TC'Unrestricted_Access);
127         begin
128            if Is_Less (Tgt, Src) then
129               Compare := -1;
130            elsif Is_Less (Src, Tgt) then
131               Compare := 1;
132            else
133               Compare := 0;
134            end if;
135         end;
136
137         if Compare < 0 then
138            Tgt := Tree_Operations.Next (Tgt);
139
140         elsif Compare > 0 then
141            Src := Tree_Operations.Next (Src);
142
143         else
144            declare
145               X : Node_Access := Tgt;
146            begin
147               Tgt := Tree_Operations.Next (Tgt);
148               Tree_Operations.Delete_Node_Sans_Free (Target, X);
149               Free (X);
150            end;
151
152            Src := Tree_Operations.Next (Src);
153         end if;
154      end loop;
155   end Difference;
156
157   function Difference (Left, Right : Tree_Type) return Tree_Type is
158   begin
159      if Left'Address = Right'Address then
160         return Tree_Type'(others => <>);  -- Empty set
161      end if;
162
163      if Left.Length = 0 then
164         return Tree_Type'(others => <>);  -- Empty set
165      end if;
166
167      if Right.Length = 0 then
168         return Copy (Left);
169      end if;
170
171      --  Per AI05-0022, the container implementation is required to detect
172      --  element tampering by a generic actual subprogram.
173
174      declare
175         Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
176         Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
177
178         Tree : Tree_Type;
179
180         L_Node : Node_Access;
181         R_Node : Node_Access;
182
183         Dst_Node : Node_Access;
184         pragma Warnings (Off, Dst_Node);
185
186      begin
187         L_Node := Left.First;
188         R_Node := Right.First;
189         loop
190            if L_Node = null then
191               exit;
192            end if;
193
194            if R_Node = null then
195               while L_Node /= null loop
196                  Insert_With_Hint
197                    (Dst_Tree => Tree,
198                     Dst_Hint => null,
199                     Src_Node => L_Node,
200                     Dst_Node => Dst_Node);
201
202                  L_Node := Tree_Operations.Next (L_Node);
203               end loop;
204
205               exit;
206            end if;
207
208            if Is_Less (L_Node, R_Node) then
209               Insert_With_Hint
210                 (Dst_Tree => Tree,
211                  Dst_Hint => null,
212                  Src_Node => L_Node,
213                  Dst_Node => Dst_Node);
214
215               L_Node := Tree_Operations.Next (L_Node);
216
217            elsif Is_Less (R_Node, L_Node) then
218               R_Node := Tree_Operations.Next (R_Node);
219
220            else
221               L_Node := Tree_Operations.Next (L_Node);
222               R_Node := Tree_Operations.Next (R_Node);
223            end if;
224         end loop;
225
226         return Tree;
227
228      exception
229         when others =>
230            Delete_Tree (Tree.Root);
231            raise;
232      end;
233   end Difference;
234
235   ------------------
236   -- Intersection --
237   ------------------
238
239   procedure Intersection
240     (Target : in out Tree_Type;
241      Source : Tree_Type)
242   is
243      Tgt : Node_Access;
244      Src : Node_Access;
245
246      Compare : Integer;
247
248   begin
249      if Target'Address = Source'Address then
250         return;
251      end if;
252
253      TC_Check (Target.TC);
254
255      if Source.Length = 0 then
256         Clear (Target);
257         return;
258      end if;
259
260      Tgt := Target.First;
261      Src := Source.First;
262      while Tgt /= null
263        and then Src /= null
264      loop
265         --  Per AI05-0022, the container implementation is required to detect
266         --  element tampering by a generic actual subprogram.
267
268         declare
269            Lock_Target : With_Lock (Target.TC'Unrestricted_Access);
270            Lock_Source : With_Lock (Source.TC'Unrestricted_Access);
271         begin
272            if Is_Less (Tgt, Src) then
273               Compare := -1;
274            elsif Is_Less (Src, Tgt) then
275               Compare := 1;
276            else
277               Compare := 0;
278            end if;
279         end;
280
281         if Compare < 0 then
282            declare
283               X : Node_Access := Tgt;
284            begin
285               Tgt := Tree_Operations.Next (Tgt);
286               Tree_Operations.Delete_Node_Sans_Free (Target, X);
287               Free (X);
288            end;
289
290         elsif Compare > 0 then
291            Src := Tree_Operations.Next (Src);
292
293         else
294            Tgt := Tree_Operations.Next (Tgt);
295            Src := Tree_Operations.Next (Src);
296         end if;
297      end loop;
298
299      while Tgt /= null loop
300         declare
301            X : Node_Access := Tgt;
302         begin
303            Tgt := Tree_Operations.Next (Tgt);
304            Tree_Operations.Delete_Node_Sans_Free (Target, X);
305            Free (X);
306         end;
307      end loop;
308   end Intersection;
309
310   function Intersection (Left, Right : Tree_Type) return Tree_Type is
311   begin
312      if Left'Address = Right'Address then
313         return Copy (Left);
314      end if;
315
316      --  Per AI05-0022, the container implementation is required to detect
317      --  element tampering by a generic actual subprogram.
318
319      declare
320         Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
321         Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
322
323         Tree : Tree_Type;
324
325         L_Node : Node_Access;
326         R_Node : Node_Access;
327
328         Dst_Node : Node_Access;
329         pragma Warnings (Off, Dst_Node);
330
331      begin
332         L_Node := Left.First;
333         R_Node := Right.First;
334         loop
335            if L_Node = null then
336               exit;
337            end if;
338
339            if R_Node = null then
340               exit;
341            end if;
342
343            if Is_Less (L_Node, R_Node) then
344               L_Node := Tree_Operations.Next (L_Node);
345
346            elsif Is_Less (R_Node, L_Node) then
347               R_Node := Tree_Operations.Next (R_Node);
348
349            else
350               Insert_With_Hint
351                 (Dst_Tree => Tree,
352                  Dst_Hint => null,
353                  Src_Node => L_Node,
354                  Dst_Node => Dst_Node);
355
356               L_Node := Tree_Operations.Next (L_Node);
357               R_Node := Tree_Operations.Next (R_Node);
358            end if;
359         end loop;
360
361         return Tree;
362
363      exception
364         when others =>
365            Delete_Tree (Tree.Root);
366            raise;
367      end;
368   end Intersection;
369
370   ---------------
371   -- Is_Subset --
372   ---------------
373
374   function Is_Subset
375     (Subset : Tree_Type;
376      Of_Set : Tree_Type) return Boolean
377   is
378   begin
379      if Subset'Address = Of_Set'Address then
380         return True;
381      end if;
382
383      if Subset.Length > Of_Set.Length then
384         return False;
385      end if;
386
387      --  Per AI05-0022, the container implementation is required to detect
388      --  element tampering by a generic actual subprogram.
389
390      declare
391         Lock_Subset : With_Lock (Subset.TC'Unrestricted_Access);
392         Lock_Of_Set : With_Lock (Of_Set.TC'Unrestricted_Access);
393
394         Subset_Node : Node_Access;
395         Set_Node    : Node_Access;
396
397      begin
398         Subset_Node := Subset.First;
399         Set_Node    := Of_Set.First;
400         loop
401            if Set_Node = null then
402               return Subset_Node = null;
403            end if;
404
405            if Subset_Node = null then
406               return True;
407            end if;
408
409            if Is_Less (Subset_Node, Set_Node) then
410               return False;
411            end if;
412
413            if Is_Less (Set_Node, Subset_Node) then
414               Set_Node := Tree_Operations.Next (Set_Node);
415            else
416               Set_Node := Tree_Operations.Next (Set_Node);
417               Subset_Node := Tree_Operations.Next (Subset_Node);
418            end if;
419         end loop;
420      end;
421   end Is_Subset;
422
423   -------------
424   -- Overlap --
425   -------------
426
427   function Overlap (Left, Right : Tree_Type) return Boolean is
428   begin
429      if Left'Address = Right'Address then
430         return Left.Length /= 0;
431      end if;
432
433      --  Per AI05-0022, the container implementation is required to detect
434      --  element tampering by a generic actual subprogram.
435
436      declare
437         Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
438         Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
439
440         L_Node : Node_Access;
441         R_Node : Node_Access;
442      begin
443         L_Node := Left.First;
444         R_Node := Right.First;
445         loop
446            if L_Node = null
447              or else R_Node = null
448            then
449               return False;
450            end if;
451
452            if Is_Less (L_Node, R_Node) then
453               L_Node := Tree_Operations.Next (L_Node);
454
455            elsif Is_Less (R_Node, L_Node) then
456               R_Node := Tree_Operations.Next (R_Node);
457
458            else
459               return True;
460            end if;
461         end loop;
462      end;
463   end Overlap;
464
465   --------------------------
466   -- Symmetric_Difference --
467   --------------------------
468
469   procedure Symmetric_Difference
470     (Target : in out Tree_Type;
471      Source : Tree_Type)
472   is
473      Tgt : Node_Access;
474      Src : Node_Access;
475
476      New_Tgt_Node : Node_Access;
477      pragma Warnings (Off, New_Tgt_Node);
478
479      Compare : Integer;
480
481   begin
482      if Target'Address = Source'Address then
483         Clear (Target);
484         return;
485      end if;
486
487      Tgt := Target.First;
488      Src := Source.First;
489      loop
490         if Tgt = null then
491            while Src /= null loop
492               Insert_With_Hint
493                 (Dst_Tree => Target,
494                  Dst_Hint => null,
495                  Src_Node => Src,
496                  Dst_Node => New_Tgt_Node);
497
498               Src := Tree_Operations.Next (Src);
499            end loop;
500
501            return;
502         end if;
503
504         if Src = null then
505            return;
506         end if;
507
508         --  Per AI05-0022, the container implementation is required to detect
509         --  element tampering by a generic actual subprogram.
510
511         declare
512            Lock_Target : With_Lock (Target.TC'Unrestricted_Access);
513            Lock_Source : With_Lock (Source.TC'Unrestricted_Access);
514         begin
515            if Is_Less (Tgt, Src) then
516               Compare := -1;
517            elsif Is_Less (Src, Tgt) then
518               Compare := 1;
519            else
520               Compare := 0;
521            end if;
522         end;
523
524         if Compare < 0 then
525            Tgt := Tree_Operations.Next (Tgt);
526
527         elsif Compare > 0 then
528            Insert_With_Hint
529              (Dst_Tree => Target,
530               Dst_Hint => Tgt,
531               Src_Node => Src,
532               Dst_Node => New_Tgt_Node);
533
534            Src := Tree_Operations.Next (Src);
535
536         else
537            declare
538               X : Node_Access := Tgt;
539            begin
540               Tgt := Tree_Operations.Next (Tgt);
541               Tree_Operations.Delete_Node_Sans_Free (Target, X);
542               Free (X);
543            end;
544
545            Src := Tree_Operations.Next (Src);
546         end if;
547      end loop;
548   end Symmetric_Difference;
549
550   function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is
551   begin
552      if Left'Address = Right'Address then
553         return Tree_Type'(others => <>);  -- Empty set
554      end if;
555
556      if Right.Length = 0 then
557         return Copy (Left);
558      end if;
559
560      if Left.Length = 0 then
561         return Copy (Right);
562      end if;
563
564      --  Per AI05-0022, the container implementation is required to detect
565      --  element tampering by a generic actual subprogram.
566
567      declare
568         Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
569         Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
570
571         Tree : Tree_Type;
572
573         L_Node : Node_Access;
574         R_Node : Node_Access;
575
576         Dst_Node : Node_Access;
577         pragma Warnings (Off, Dst_Node);
578
579      begin
580         L_Node := Left.First;
581         R_Node := Right.First;
582         loop
583            if L_Node = null then
584               while R_Node /= null loop
585                  Insert_With_Hint
586                    (Dst_Tree => Tree,
587                     Dst_Hint => null,
588                     Src_Node => R_Node,
589                     Dst_Node => Dst_Node);
590                  R_Node := Tree_Operations.Next (R_Node);
591               end loop;
592
593               exit;
594            end if;
595
596            if R_Node = null then
597               while L_Node /= null loop
598                  Insert_With_Hint
599                    (Dst_Tree => Tree,
600                     Dst_Hint => null,
601                     Src_Node => L_Node,
602                     Dst_Node => Dst_Node);
603
604                  L_Node := Tree_Operations.Next (L_Node);
605               end loop;
606
607               exit;
608            end if;
609
610            if Is_Less (L_Node, R_Node) then
611               Insert_With_Hint
612                 (Dst_Tree => Tree,
613                  Dst_Hint => null,
614                  Src_Node => L_Node,
615                  Dst_Node => Dst_Node);
616
617               L_Node := Tree_Operations.Next (L_Node);
618
619            elsif Is_Less (R_Node, L_Node) then
620               Insert_With_Hint
621                 (Dst_Tree => Tree,
622                  Dst_Hint => null,
623                  Src_Node => R_Node,
624                  Dst_Node => Dst_Node);
625
626               R_Node := Tree_Operations.Next (R_Node);
627
628            else
629               L_Node := Tree_Operations.Next (L_Node);
630               R_Node := Tree_Operations.Next (R_Node);
631            end if;
632         end loop;
633
634         return Tree;
635
636      exception
637         when others =>
638            Delete_Tree (Tree.Root);
639            raise;
640      end;
641   end Symmetric_Difference;
642
643   -----------
644   -- Union --
645   -----------
646
647   procedure Union (Target : in out Tree_Type; Source : Tree_Type) is
648      Hint : Node_Access;
649
650      procedure Process (Node : Node_Access);
651      pragma Inline (Process);
652
653      procedure Iterate is new Tree_Operations.Generic_Iteration (Process);
654
655      -------------
656      -- Process --
657      -------------
658
659      procedure Process (Node : Node_Access) is
660      begin
661         Insert_With_Hint
662           (Dst_Tree => Target,
663            Dst_Hint => Hint,  -- use node most recently inserted as hint
664            Src_Node => Node,
665            Dst_Node => Hint);
666      end Process;
667
668   --  Start of processing for Union
669
670   begin
671      if Target'Address = Source'Address then
672         return;
673      end if;
674
675      --  Per AI05-0022, the container implementation is required to detect
676      --  element tampering by a generic actual subprogram.
677
678      declare
679         Lock_Source : With_Lock (Source.TC'Unrestricted_Access);
680      begin
681         Iterate (Source);
682      end;
683   end Union;
684
685   function Union (Left, Right : Tree_Type) return Tree_Type is
686   begin
687      if Left'Address = Right'Address then
688         return Copy (Left);
689      end if;
690
691      if Left.Length = 0 then
692         return Copy (Right);
693      end if;
694
695      if Right.Length = 0 then
696         return Copy (Left);
697      end if;
698
699      declare
700         Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
701         Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
702
703         Tree : Tree_Type := Copy (Left);
704
705         Hint : Node_Access;
706
707         procedure Process (Node : Node_Access);
708         pragma Inline (Process);
709
710         procedure Iterate is
711           new Tree_Operations.Generic_Iteration (Process);
712
713         -------------
714         -- Process --
715         -------------
716
717         procedure Process (Node : Node_Access) is
718         begin
719            Insert_With_Hint
720              (Dst_Tree => Tree,
721               Dst_Hint => Hint,  -- use node most recently inserted as hint
722               Src_Node => Node,
723               Dst_Node => Hint);
724         end Process;
725
726      --  Start of processing for Union
727
728      begin
729         Iterate (Right);
730         return Tree;
731
732      exception
733         when others =>
734            Delete_Tree (Tree.Root);
735            raise;
736      end;
737   end Union;
738
739end Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
740