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