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