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-- 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_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 703end Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; 704