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