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-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 30with System; use type System.Address; 31 32package 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 630end Ada.Containers.Red_Black_Trees.Generic_Set_Operations; 631