1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ S E T S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2010-2012, 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 28with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; 29pragma Elaborate_All 30 (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); 31 32with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; 33pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); 34 35with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; 36pragma Elaborate_All 37 (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations); 38 39with System; use type System.Address; 40 41package body Ada.Containers.Formal_Ordered_Sets is 42 43 ------------------------------ 44 -- Access to Fields of Node -- 45 ------------------------------ 46 47 -- These subprograms provide functional notation for access to fields 48 -- of a node, and procedural notation for modifiying these fields. 49 50 function Color (Node : Node_Type) return Red_Black_Trees.Color_Type; 51 pragma Inline (Color); 52 53 function Left_Son (Node : Node_Type) return Count_Type; 54 pragma Inline (Left); 55 56 function Parent (Node : Node_Type) return Count_Type; 57 pragma Inline (Parent); 58 59 function Right_Son (Node : Node_Type) return Count_Type; 60 pragma Inline (Right); 61 62 procedure Set_Color 63 (Node : in out Node_Type; 64 Color : Red_Black_Trees.Color_Type); 65 pragma Inline (Set_Color); 66 67 procedure Set_Left (Node : in out Node_Type; Left : Count_Type); 68 pragma Inline (Set_Left); 69 70 procedure Set_Right (Node : in out Node_Type; Right : Count_Type); 71 pragma Inline (Set_Right); 72 73 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); 74 pragma Inline (Set_Parent); 75 76 ----------------------- 77 -- Local Subprograms -- 78 ----------------------- 79 80 -- Comments needed??? 81 82 generic 83 with procedure Set_Element (Node : in out Node_Type); 84 procedure Generic_Allocate 85 (Tree : in out Tree_Types.Tree_Type'Class; 86 Node : out Count_Type); 87 88 procedure Free (Tree : in out Set; X : Count_Type); 89 90 procedure Insert_Sans_Hint 91 (Container : in out Set; 92 New_Item : Element_Type; 93 Node : out Count_Type; 94 Inserted : out Boolean); 95 96 procedure Insert_With_Hint 97 (Dst_Set : in out Set; 98 Dst_Hint : Count_Type; 99 Src_Node : Node_Type; 100 Dst_Node : out Count_Type); 101 102 function Is_Greater_Element_Node 103 (Left : Element_Type; 104 Right : Node_Type) return Boolean; 105 pragma Inline (Is_Greater_Element_Node); 106 107 function Is_Less_Element_Node 108 (Left : Element_Type; 109 Right : Node_Type) return Boolean; 110 pragma Inline (Is_Less_Element_Node); 111 112 function Is_Less_Node_Node (L, R : Node_Type) return Boolean; 113 pragma Inline (Is_Less_Node_Node); 114 115 procedure Replace_Element 116 (Tree : in out Set; 117 Node : Count_Type; 118 Item : Element_Type); 119 120 -------------------------- 121 -- Local Instantiations -- 122 -------------------------- 123 124 package Tree_Operations is 125 new Red_Black_Trees.Generic_Bounded_Operations 126 (Tree_Types, 127 Left => Left_Son, 128 Right => Right_Son); 129 130 use Tree_Operations; 131 132 package Element_Keys is 133 new Red_Black_Trees.Generic_Bounded_Keys 134 (Tree_Operations => Tree_Operations, 135 Key_Type => Element_Type, 136 Is_Less_Key_Node => Is_Less_Element_Node, 137 Is_Greater_Key_Node => Is_Greater_Element_Node); 138 139 package Set_Ops is 140 new Red_Black_Trees.Generic_Bounded_Set_Operations 141 (Tree_Operations => Tree_Operations, 142 Set_Type => Set, 143 Assign => Assign, 144 Insert_With_Hint => Insert_With_Hint, 145 Is_Less => Is_Less_Node_Node); 146 147 --------- 148 -- "=" -- 149 --------- 150 151 function "=" (Left, Right : Set) return Boolean is 152 Lst : Count_Type; 153 Node : Count_Type; 154 ENode : Count_Type; 155 156 begin 157 if Length (Left) /= Length (Right) then 158 return False; 159 end if; 160 161 if Is_Empty (Left) then 162 return True; 163 end if; 164 165 Lst := Next (Left, Last (Left).Node); 166 167 Node := First (Left).Node; 168 while Node /= Lst loop 169 ENode := Find (Right, Left.Nodes (Node).Element).Node; 170 if ENode = 0 171 or else Left.Nodes (Node).Element /= Right.Nodes (ENode).Element 172 then 173 return False; 174 end if; 175 176 Node := Next (Left, Node); 177 end loop; 178 179 return True; 180 end "="; 181 182 ------------ 183 -- Assign -- 184 ------------ 185 186 procedure Assign (Target : in out Set; Source : Set) is 187 procedure Append_Element (Source_Node : Count_Type); 188 189 procedure Append_Elements is 190 new Tree_Operations.Generic_Iteration (Append_Element); 191 192 -------------------- 193 -- Append_Element -- 194 -------------------- 195 196 procedure Append_Element (Source_Node : Count_Type) is 197 SN : Node_Type renames Source.Nodes (Source_Node); 198 199 procedure Set_Element (Node : in out Node_Type); 200 pragma Inline (Set_Element); 201 202 function New_Node return Count_Type; 203 pragma Inline (New_Node); 204 205 procedure Insert_Post is 206 new Element_Keys.Generic_Insert_Post (New_Node); 207 208 procedure Unconditional_Insert_Sans_Hint is 209 new Element_Keys.Generic_Unconditional_Insert (Insert_Post); 210 211 procedure Unconditional_Insert_Avec_Hint is 212 new Element_Keys.Generic_Unconditional_Insert_With_Hint 213 (Insert_Post, 214 Unconditional_Insert_Sans_Hint); 215 216 procedure Allocate is new Generic_Allocate (Set_Element); 217 218 -------------- 219 -- New_Node -- 220 -------------- 221 222 function New_Node return Count_Type is 223 Result : Count_Type; 224 begin 225 Allocate (Target, Result); 226 return Result; 227 end New_Node; 228 229 ----------------- 230 -- Set_Element -- 231 ----------------- 232 233 procedure Set_Element (Node : in out Node_Type) is 234 begin 235 Node.Element := SN.Element; 236 end Set_Element; 237 238 -- Local variables 239 240 Target_Node : Count_Type; 241 242 -- Start of processing for Append_Element 243 244 begin 245 Unconditional_Insert_Avec_Hint 246 (Tree => Target, 247 Hint => 0, 248 Key => SN.Element, 249 Node => Target_Node); 250 end Append_Element; 251 252 -- Start of processing for Assign 253 254 begin 255 if Target'Address = Source'Address then 256 return; 257 end if; 258 259 if Target.Capacity < Source.Length then 260 raise Constraint_Error 261 with "Target capacity is less than Source length"; 262 end if; 263 264 Tree_Operations.Clear_Tree (Target); 265 Append_Elements (Source); 266 end Assign; 267 268 ------------- 269 -- Ceiling -- 270 ------------- 271 272 function Ceiling (Container : Set; Item : Element_Type) return Cursor is 273 Node : constant Count_Type := Element_Keys.Ceiling (Container, Item); 274 275 begin 276 if Node = 0 then 277 return No_Element; 278 end if; 279 280 return (Node => Node); 281 end Ceiling; 282 283 ----------- 284 -- Clear -- 285 ----------- 286 287 procedure Clear (Container : in out Set) is 288 begin 289 Tree_Operations.Clear_Tree (Container); 290 end Clear; 291 292 ----------- 293 -- Color -- 294 ----------- 295 296 function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is 297 begin 298 return Node.Color; 299 end Color; 300 301 -------------- 302 -- Contains -- 303 -------------- 304 305 function Contains 306 (Container : Set; 307 Item : Element_Type) return Boolean 308 is 309 begin 310 return Find (Container, Item) /= No_Element; 311 end Contains; 312 313 ---------- 314 -- Copy -- 315 ---------- 316 317 function Copy (Source : Set; Capacity : Count_Type := 0) return Set is 318 Node : Count_Type; 319 N : Count_Type; 320 Target : Set (Count_Type'Max (Source.Capacity, Capacity)); 321 322 begin 323 if Length (Source) > 0 then 324 Target.Length := Source.Length; 325 Target.Root := Source.Root; 326 Target.First := Source.First; 327 Target.Last := Source.Last; 328 Target.Free := Source.Free; 329 330 Node := 1; 331 while Node <= Source.Capacity loop 332 Target.Nodes (Node).Element := 333 Source.Nodes (Node).Element; 334 Target.Nodes (Node).Parent := 335 Source.Nodes (Node).Parent; 336 Target.Nodes (Node).Left := 337 Source.Nodes (Node).Left; 338 Target.Nodes (Node).Right := 339 Source.Nodes (Node).Right; 340 Target.Nodes (Node).Color := 341 Source.Nodes (Node).Color; 342 Target.Nodes (Node).Has_Element := 343 Source.Nodes (Node).Has_Element; 344 Node := Node + 1; 345 end loop; 346 347 while Node <= Target.Capacity loop 348 N := Node; 349 Formal_Ordered_Sets.Free (Tree => Target, X => N); 350 Node := Node + 1; 351 end loop; 352 end if; 353 354 return Target; 355 end Copy; 356 357 ------------ 358 -- Delete -- 359 ------------ 360 361 procedure Delete (Container : in out Set; Position : in out Cursor) is 362 begin 363 if not Has_Element (Container, Position) then 364 raise Constraint_Error with "Position cursor has no element"; 365 end if; 366 367 pragma Assert (Vet (Container, Position.Node), 368 "bad cursor in Delete"); 369 370 Tree_Operations.Delete_Node_Sans_Free (Container, 371 Position.Node); 372 Formal_Ordered_Sets.Free (Container, Position.Node); 373 Position := No_Element; 374 end Delete; 375 376 procedure Delete (Container : in out Set; Item : Element_Type) is 377 X : constant Count_Type := Element_Keys.Find (Container, Item); 378 379 begin 380 if X = 0 then 381 raise Constraint_Error with "attempt to delete element not in set"; 382 end if; 383 384 Tree_Operations.Delete_Node_Sans_Free (Container, X); 385 Formal_Ordered_Sets.Free (Container, X); 386 end Delete; 387 388 ------------------ 389 -- Delete_First -- 390 ------------------ 391 392 procedure Delete_First (Container : in out Set) is 393 X : constant Count_Type := Container.First; 394 begin 395 if X /= 0 then 396 Tree_Operations.Delete_Node_Sans_Free (Container, X); 397 Formal_Ordered_Sets.Free (Container, X); 398 end if; 399 end Delete_First; 400 401 ----------------- 402 -- Delete_Last -- 403 ----------------- 404 405 procedure Delete_Last (Container : in out Set) is 406 X : constant Count_Type := Container.Last; 407 begin 408 if X /= 0 then 409 Tree_Operations.Delete_Node_Sans_Free (Container, X); 410 Formal_Ordered_Sets.Free (Container, X); 411 end if; 412 end Delete_Last; 413 414 ---------------- 415 -- Difference -- 416 ---------------- 417 418 procedure Difference (Target : in out Set; Source : Set) is 419 begin 420 Set_Ops.Set_Difference (Target, Source); 421 end Difference; 422 423 function Difference (Left, Right : Set) return Set is 424 begin 425 if Left'Address = Right'Address then 426 return Empty_Set; 427 end if; 428 429 if Length (Left) = 0 then 430 return Empty_Set; 431 end if; 432 433 if Length (Right) = 0 then 434 return Left.Copy; 435 end if; 436 437 return S : Set (Length (Left)) do 438 Assign (S, Set_Ops.Set_Difference (Left, Right)); 439 end return; 440 end Difference; 441 442 ------------- 443 -- Element -- 444 ------------- 445 446 function Element (Container : Set; Position : Cursor) return Element_Type is 447 begin 448 if not Has_Element (Container, Position) then 449 raise Constraint_Error with "Position cursor has no element"; 450 end if; 451 452 pragma Assert (Vet (Container, Position.Node), 453 "bad cursor in Element"); 454 455 return Container.Nodes (Position.Node).Element; 456 end Element; 457 458 ------------------------- 459 -- Equivalent_Elements -- 460 ------------------------- 461 462 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is 463 begin 464 if Left < Right 465 or else Right < Left 466 then 467 return False; 468 else 469 return True; 470 end if; 471 end Equivalent_Elements; 472 473 --------------------- 474 -- Equivalent_Sets -- 475 --------------------- 476 477 function Equivalent_Sets (Left, Right : Set) return Boolean is 478 function Is_Equivalent_Node_Node 479 (L, R : Node_Type) return Boolean; 480 pragma Inline (Is_Equivalent_Node_Node); 481 482 function Is_Equivalent is 483 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); 484 485 ----------------------------- 486 -- Is_Equivalent_Node_Node -- 487 ----------------------------- 488 489 function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is 490 begin 491 if L.Element < R.Element then 492 return False; 493 elsif R.Element < L.Element then 494 return False; 495 else 496 return True; 497 end if; 498 end Is_Equivalent_Node_Node; 499 500 -- Start of processing for Equivalent_Sets 501 502 begin 503 return Is_Equivalent (Left, Right); 504 end Equivalent_Sets; 505 506 ------------- 507 -- Exclude -- 508 ------------- 509 510 procedure Exclude (Container : in out Set; Item : Element_Type) is 511 X : constant Count_Type := Element_Keys.Find (Container, Item); 512 begin 513 if X /= 0 then 514 Tree_Operations.Delete_Node_Sans_Free (Container, X); 515 Formal_Ordered_Sets.Free (Container, X); 516 end if; 517 end Exclude; 518 519 ---------- 520 -- Find -- 521 ---------- 522 523 function Find (Container : Set; Item : Element_Type) return Cursor is 524 Node : constant Count_Type := Element_Keys.Find (Container, Item); 525 526 begin 527 if Node = 0 then 528 return No_Element; 529 end if; 530 531 return (Node => Node); 532 end Find; 533 534 ----------- 535 -- First -- 536 ----------- 537 538 function First (Container : Set) return Cursor is 539 begin 540 if Length (Container) = 0 then 541 return No_Element; 542 end if; 543 544 return (Node => Container.First); 545 end First; 546 547 ------------------- 548 -- First_Element -- 549 ------------------- 550 551 function First_Element (Container : Set) return Element_Type is 552 Fst : constant Count_Type := First (Container).Node; 553 begin 554 if Fst = 0 then 555 raise Constraint_Error with "set is empty"; 556 end if; 557 558 declare 559 N : Tree_Types.Nodes_Type renames Container.Nodes; 560 begin 561 return N (Fst).Element; 562 end; 563 end First_Element; 564 565 ----------- 566 -- Floor -- 567 ----------- 568 569 function Floor (Container : Set; Item : Element_Type) return Cursor is 570 begin 571 declare 572 Node : constant Count_Type := Element_Keys.Floor (Container, Item); 573 574 begin 575 if Node = 0 then 576 return No_Element; 577 end if; 578 579 return (Node => Node); 580 end; 581 end Floor; 582 583 ---------- 584 -- Free -- 585 ---------- 586 587 procedure Free (Tree : in out Set; X : Count_Type) is 588 begin 589 Tree.Nodes (X).Has_Element := False; 590 Tree_Operations.Free (Tree, X); 591 end Free; 592 593 ---------------------- 594 -- Generic_Allocate -- 595 ---------------------- 596 597 procedure Generic_Allocate 598 (Tree : in out Tree_Types.Tree_Type'Class; 599 Node : out Count_Type) 600 is 601 procedure Allocate is 602 new Tree_Operations.Generic_Allocate (Set_Element); 603 begin 604 Allocate (Tree, Node); 605 Tree.Nodes (Node).Has_Element := True; 606 end Generic_Allocate; 607 608 ------------------ 609 -- Generic_Keys -- 610 ------------------ 611 612 package body Generic_Keys is 613 614 ----------------------- 615 -- Local Subprograms -- 616 ----------------------- 617 618 function Is_Greater_Key_Node 619 (Left : Key_Type; 620 Right : Node_Type) return Boolean; 621 pragma Inline (Is_Greater_Key_Node); 622 623 function Is_Less_Key_Node 624 (Left : Key_Type; 625 Right : Node_Type) return Boolean; 626 pragma Inline (Is_Less_Key_Node); 627 628 -------------------------- 629 -- Local Instantiations -- 630 -------------------------- 631 632 package Key_Keys is 633 new Red_Black_Trees.Generic_Bounded_Keys 634 (Tree_Operations => Tree_Operations, 635 Key_Type => Key_Type, 636 Is_Less_Key_Node => Is_Less_Key_Node, 637 Is_Greater_Key_Node => Is_Greater_Key_Node); 638 639 ------------- 640 -- Ceiling -- 641 ------------- 642 643 function Ceiling (Container : Set; Key : Key_Type) return Cursor is 644 Node : constant Count_Type := Key_Keys.Ceiling (Container, Key); 645 646 begin 647 if Node = 0 then 648 return No_Element; 649 end if; 650 651 return (Node => Node); 652 end Ceiling; 653 654 -------------- 655 -- Contains -- 656 -------------- 657 658 function Contains (Container : Set; Key : Key_Type) return Boolean is 659 begin 660 return Find (Container, Key) /= No_Element; 661 end Contains; 662 663 ------------ 664 -- Delete -- 665 ------------ 666 667 procedure Delete (Container : in out Set; Key : Key_Type) is 668 X : constant Count_Type := Key_Keys.Find (Container, Key); 669 670 begin 671 if X = 0 then 672 raise Constraint_Error with "attempt to delete key not in set"; 673 end if; 674 675 Delete_Node_Sans_Free (Container, X); 676 Formal_Ordered_Sets.Free (Container, X); 677 end Delete; 678 679 ------------- 680 -- Element -- 681 ------------- 682 683 function Element (Container : Set; Key : Key_Type) return Element_Type is 684 Node : constant Count_Type := Key_Keys.Find (Container, Key); 685 686 begin 687 if Node = 0 then 688 raise Constraint_Error with "key not in set"; 689 end if; 690 691 declare 692 N : Tree_Types.Nodes_Type renames Container.Nodes; 693 begin 694 return N (Node).Element; 695 end; 696 end Element; 697 698 --------------------- 699 -- Equivalent_Keys -- 700 --------------------- 701 702 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is 703 begin 704 if Left < Right 705 or else Right < Left 706 then 707 return False; 708 else 709 return True; 710 end if; 711 end Equivalent_Keys; 712 713 ------------- 714 -- Exclude -- 715 ------------- 716 717 procedure Exclude (Container : in out Set; Key : Key_Type) is 718 X : constant Count_Type := Key_Keys.Find (Container, Key); 719 begin 720 if X /= 0 then 721 Delete_Node_Sans_Free (Container, X); 722 Formal_Ordered_Sets.Free (Container, X); 723 end if; 724 end Exclude; 725 726 ---------- 727 -- Find -- 728 ---------- 729 730 function Find (Container : Set; Key : Key_Type) return Cursor is 731 Node : constant Count_Type := Key_Keys.Find (Container, Key); 732 begin 733 return (if Node = 0 then No_Element else (Node => Node)); 734 end Find; 735 736 ----------- 737 -- Floor -- 738 ----------- 739 740 function Floor (Container : Set; Key : Key_Type) return Cursor is 741 Node : constant Count_Type := Key_Keys.Floor (Container, Key); 742 begin 743 return (if Node = 0 then No_Element else (Node => Node)); 744 end Floor; 745 746 ------------------------- 747 -- Is_Greater_Key_Node -- 748 ------------------------- 749 750 function Is_Greater_Key_Node 751 (Left : Key_Type; 752 Right : Node_Type) return Boolean 753 is 754 begin 755 return Key (Right.Element) < Left; 756 end Is_Greater_Key_Node; 757 758 ---------------------- 759 -- Is_Less_Key_Node -- 760 ---------------------- 761 762 function Is_Less_Key_Node 763 (Left : Key_Type; 764 Right : Node_Type) return Boolean 765 is 766 begin 767 return Left < Key (Right.Element); 768 end Is_Less_Key_Node; 769 770 --------- 771 -- Key -- 772 --------- 773 774 function Key (Container : Set; Position : Cursor) return Key_Type is 775 begin 776 if not Has_Element (Container, Position) then 777 raise Constraint_Error with 778 "Position cursor has no element"; 779 end if; 780 781 pragma Assert (Vet (Container, Position.Node), 782 "bad cursor in Key"); 783 784 declare 785 N : Tree_Types.Nodes_Type renames Container.Nodes; 786 begin 787 return Key (N (Position.Node).Element); 788 end; 789 end Key; 790 791 ------------- 792 -- Replace -- 793 ------------- 794 795 procedure Replace 796 (Container : in out Set; 797 Key : Key_Type; 798 New_Item : Element_Type) 799 is 800 Node : constant Count_Type := Key_Keys.Find (Container, Key); 801 begin 802 if not Has_Element (Container, (Node => Node)) then 803 raise Constraint_Error with 804 "attempt to replace key not in set"; 805 else 806 Replace_Element (Container, Node, New_Item); 807 end if; 808 end Replace; 809 810 ----------------------------------- 811 -- Update_Element_Preserving_Key -- 812 ----------------------------------- 813 814 procedure Update_Element_Preserving_Key 815 (Container : in out Set; 816 Position : Cursor; 817 Process : not null access procedure (Element : in out Element_Type)) 818 is 819 begin 820 if not Has_Element (Container, Position) then 821 raise Constraint_Error with 822 "Position cursor has no element"; 823 end if; 824 825 pragma Assert (Vet (Container, Position.Node), 826 "bad cursor in Update_Element_Preserving_Key"); 827 828 declare 829 N : Tree_Types.Nodes_Type renames Container.Nodes; 830 831 E : Element_Type renames N (Position.Node).Element; 832 K : constant Key_Type := Key (E); 833 834 B : Natural renames Container.Busy; 835 L : Natural renames Container.Lock; 836 837 begin 838 B := B + 1; 839 L := L + 1; 840 841 begin 842 Process (E); 843 exception 844 when others => 845 L := L - 1; 846 B := B - 1; 847 raise; 848 end; 849 850 L := L - 1; 851 B := B - 1; 852 853 if Equivalent_Keys (K, Key (E)) then 854 return; 855 end if; 856 end; 857 858 declare 859 X : constant Count_Type := Position.Node; 860 begin 861 Tree_Operations.Delete_Node_Sans_Free (Container, X); 862 Formal_Ordered_Sets.Free (Container, X); 863 end; 864 865 raise Program_Error with "key was modified"; 866 end Update_Element_Preserving_Key; 867 868 end Generic_Keys; 869 870 ----------------- 871 -- Has_Element -- 872 ----------------- 873 874 function Has_Element (Container : Set; Position : Cursor) return Boolean is 875 begin 876 if Position.Node = 0 then 877 return False; 878 else 879 return Container.Nodes (Position.Node).Has_Element; 880 end if; 881 end Has_Element; 882 883 ------------- 884 -- Include -- 885 ------------- 886 887 procedure Include (Container : in out Set; New_Item : Element_Type) is 888 Position : Cursor; 889 Inserted : Boolean; 890 891 begin 892 Insert (Container, New_Item, Position, Inserted); 893 894 if not Inserted then 895 if Container.Lock > 0 then 896 raise Program_Error with 897 "attempt to tamper with cursors (set is locked)"; 898 end if; 899 900 declare 901 N : Tree_Types.Nodes_Type renames Container.Nodes; 902 begin 903 N (Position.Node).Element := New_Item; 904 end; 905 end if; 906 end Include; 907 908 ------------ 909 -- Insert -- 910 ------------ 911 912 procedure Insert 913 (Container : in out Set; 914 New_Item : Element_Type; 915 Position : out Cursor; 916 Inserted : out Boolean) 917 is 918 begin 919 Insert_Sans_Hint (Container, New_Item, Position.Node, Inserted); 920 end Insert; 921 922 procedure Insert 923 (Container : in out Set; 924 New_Item : Element_Type) 925 is 926 Position : Cursor; 927 Inserted : Boolean; 928 929 begin 930 Insert (Container, New_Item, Position, Inserted); 931 932 if not Inserted then 933 raise Constraint_Error with 934 "attempt to insert element already in set"; 935 end if; 936 end Insert; 937 938 ---------------------- 939 -- Insert_Sans_Hint -- 940 ---------------------- 941 942 procedure Insert_Sans_Hint 943 (Container : in out Set; 944 New_Item : Element_Type; 945 Node : out Count_Type; 946 Inserted : out Boolean) 947 is 948 procedure Set_Element (Node : in out Node_Type); 949 950 function New_Node return Count_Type; 951 pragma Inline (New_Node); 952 953 procedure Insert_Post is 954 new Element_Keys.Generic_Insert_Post (New_Node); 955 956 procedure Conditional_Insert_Sans_Hint is 957 new Element_Keys.Generic_Conditional_Insert (Insert_Post); 958 959 procedure Allocate is new Generic_Allocate (Set_Element); 960 961 -------------- 962 -- New_Node -- 963 -------------- 964 965 function New_Node return Count_Type is 966 Result : Count_Type; 967 begin 968 Allocate (Container, Result); 969 return Result; 970 end New_Node; 971 972 ----------------- 973 -- Set_Element -- 974 ----------------- 975 976 procedure Set_Element (Node : in out Node_Type) is 977 begin 978 Node.Element := New_Item; 979 end Set_Element; 980 981 -- Start of processing for Insert_Sans_Hint 982 983 begin 984 Conditional_Insert_Sans_Hint 985 (Container, 986 New_Item, 987 Node, 988 Inserted); 989 end Insert_Sans_Hint; 990 991 ---------------------- 992 -- Insert_With_Hint -- 993 ---------------------- 994 995 procedure Insert_With_Hint 996 (Dst_Set : in out Set; 997 Dst_Hint : Count_Type; 998 Src_Node : Node_Type; 999 Dst_Node : out Count_Type) 1000 is 1001 Success : Boolean; 1002 pragma Unreferenced (Success); 1003 1004 procedure Set_Element (Node : in out Node_Type); 1005 1006 function New_Node return Count_Type; 1007 pragma Inline (New_Node); 1008 1009 procedure Insert_Post is 1010 new Element_Keys.Generic_Insert_Post (New_Node); 1011 1012 procedure Insert_Sans_Hint is 1013 new Element_Keys.Generic_Conditional_Insert (Insert_Post); 1014 1015 procedure Local_Insert_With_Hint is 1016 new Element_Keys.Generic_Conditional_Insert_With_Hint 1017 (Insert_Post, Insert_Sans_Hint); 1018 1019 procedure Allocate is new Generic_Allocate (Set_Element); 1020 1021 -------------- 1022 -- New_Node -- 1023 -------------- 1024 1025 function New_Node return Count_Type is 1026 Result : Count_Type; 1027 begin 1028 Allocate (Dst_Set, Result); 1029 return Result; 1030 end New_Node; 1031 1032 ----------------- 1033 -- Set_Element -- 1034 ----------------- 1035 1036 procedure Set_Element (Node : in out Node_Type) is 1037 begin 1038 Node.Element := Src_Node.Element; 1039 end Set_Element; 1040 1041 -- Start of processing for Insert_With_Hint 1042 1043 begin 1044 Local_Insert_With_Hint 1045 (Dst_Set, 1046 Dst_Hint, 1047 Src_Node.Element, 1048 Dst_Node, 1049 Success); 1050 end Insert_With_Hint; 1051 1052 ------------------ 1053 -- Intersection -- 1054 ------------------ 1055 1056 procedure Intersection (Target : in out Set; Source : Set) is 1057 begin 1058 Set_Ops.Set_Intersection (Target, Source); 1059 end Intersection; 1060 1061 function Intersection (Left, Right : Set) return Set is 1062 begin 1063 if Left'Address = Right'Address then 1064 return Left.Copy; 1065 end if; 1066 1067 return S : Set (Count_Type'Min (Length (Left), Length (Right))) do 1068 Assign (S, Set_Ops.Set_Intersection (Left, Right)); 1069 end return; 1070 end Intersection; 1071 1072 -------------- 1073 -- Is_Empty -- 1074 -------------- 1075 1076 function Is_Empty (Container : Set) return Boolean is 1077 begin 1078 return Length (Container) = 0; 1079 end Is_Empty; 1080 1081 ----------------------------- 1082 -- Is_Greater_Element_Node -- 1083 ----------------------------- 1084 1085 function Is_Greater_Element_Node 1086 (Left : Element_Type; 1087 Right : Node_Type) return Boolean 1088 is 1089 begin 1090 -- Compute e > node same as node < e 1091 1092 return Right.Element < Left; 1093 end Is_Greater_Element_Node; 1094 1095 -------------------------- 1096 -- Is_Less_Element_Node -- 1097 -------------------------- 1098 1099 function Is_Less_Element_Node 1100 (Left : Element_Type; 1101 Right : Node_Type) return Boolean 1102 is 1103 begin 1104 return Left < Right.Element; 1105 end Is_Less_Element_Node; 1106 1107 ----------------------- 1108 -- Is_Less_Node_Node -- 1109 ----------------------- 1110 1111 function Is_Less_Node_Node (L, R : Node_Type) return Boolean is 1112 begin 1113 return L.Element < R.Element; 1114 end Is_Less_Node_Node; 1115 1116 --------------- 1117 -- Is_Subset -- 1118 --------------- 1119 1120 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is 1121 begin 1122 return Set_Ops.Set_Subset (Subset, Of_Set => Of_Set); 1123 end Is_Subset; 1124 1125 ------------- 1126 -- Iterate -- 1127 ------------- 1128 1129 procedure Iterate 1130 (Container : Set; 1131 Process : not null access procedure (Container : Set; 1132 Position : Cursor)) 1133 is 1134 procedure Process_Node (Node : Count_Type); 1135 pragma Inline (Process_Node); 1136 1137 procedure Local_Iterate is 1138 new Tree_Operations.Generic_Iteration (Process_Node); 1139 1140 ------------------ 1141 -- Process_Node -- 1142 ------------------ 1143 1144 procedure Process_Node (Node : Count_Type) is 1145 begin 1146 Process (Container, (Node => Node)); 1147 end Process_Node; 1148 1149 -- Local variables 1150 1151 B : Natural renames Container'Unrestricted_Access.Busy; 1152 1153 -- Start of prccessing for Iterate 1154 1155 begin 1156 B := B + 1; 1157 1158 begin 1159 Local_Iterate (Container); 1160 exception 1161 when others => 1162 B := B - 1; 1163 raise; 1164 end; 1165 1166 B := B - 1; 1167 end Iterate; 1168 1169 ---------- 1170 -- Last -- 1171 ---------- 1172 1173 function Last (Container : Set) return Cursor is 1174 begin 1175 return (if Length (Container) = 0 1176 then No_Element 1177 else (Node => Container.Last)); 1178 end Last; 1179 1180 ------------------ 1181 -- Last_Element -- 1182 ------------------ 1183 1184 function Last_Element (Container : Set) return Element_Type is 1185 begin 1186 if Last (Container).Node = 0 then 1187 raise Constraint_Error with "set is empty"; 1188 end if; 1189 1190 declare 1191 N : Tree_Types.Nodes_Type renames Container.Nodes; 1192 begin 1193 return N (Last (Container).Node).Element; 1194 end; 1195 end Last_Element; 1196 1197 ---------- 1198 -- Left -- 1199 ---------- 1200 1201 function Left (Container : Set; Position : Cursor) return Set is 1202 Curs : Cursor := Position; 1203 C : Set (Container.Capacity) := Copy (Container, Container.Capacity); 1204 Node : Count_Type; 1205 1206 begin 1207 if Curs = No_Element then 1208 return C; 1209 end if; 1210 1211 if not Has_Element (Container, Curs) then 1212 raise Constraint_Error; 1213 end if; 1214 1215 while Curs.Node /= 0 loop 1216 Node := Curs.Node; 1217 Delete (C, Curs); 1218 Curs := Next (Container, (Node => Node)); 1219 end loop; 1220 1221 return C; 1222 end Left; 1223 1224 -------------- 1225 -- Left_Son -- 1226 -------------- 1227 1228 function Left_Son (Node : Node_Type) return Count_Type is 1229 begin 1230 return Node.Left; 1231 end Left_Son; 1232 1233 ------------ 1234 -- Length -- 1235 ------------ 1236 1237 function Length (Container : Set) return Count_Type is 1238 begin 1239 return Container.Length; 1240 end Length; 1241 1242 ---------- 1243 -- Move -- 1244 ---------- 1245 1246 procedure Move (Target : in out Set; Source : in out Set) is 1247 N : Tree_Types.Nodes_Type renames Source.Nodes; 1248 X : Count_Type; 1249 1250 begin 1251 if Target'Address = Source'Address then 1252 return; 1253 end if; 1254 1255 if Target.Capacity < Length (Source) then 1256 raise Constraint_Error with -- ??? 1257 "Source length exceeds Target capacity"; 1258 end if; 1259 1260 if Source.Busy > 0 then 1261 raise Program_Error with 1262 "attempt to tamper with cursors of Source (list is busy)"; 1263 end if; 1264 1265 Clear (Target); 1266 1267 loop 1268 X := Source.First; 1269 exit when X = 0; 1270 1271 Insert (Target, N (X).Element); -- optimize??? 1272 1273 Tree_Operations.Delete_Node_Sans_Free (Source, X); 1274 Formal_Ordered_Sets.Free (Source, X); 1275 end loop; 1276 end Move; 1277 1278 ---------- 1279 -- Next -- 1280 ---------- 1281 1282 function Next (Container : Set; Position : Cursor) return Cursor is 1283 begin 1284 if Position = No_Element then 1285 return No_Element; 1286 end if; 1287 1288 if not Has_Element (Container, Position) then 1289 raise Constraint_Error; 1290 end if; 1291 1292 pragma Assert (Vet (Container, Position.Node), 1293 "bad cursor in Next"); 1294 return (Node => Tree_Operations.Next (Container, Position.Node)); 1295 end Next; 1296 1297 procedure Next (Container : Set; Position : in out Cursor) is 1298 begin 1299 Position := Next (Container, Position); 1300 end Next; 1301 1302 ------------- 1303 -- Overlap -- 1304 ------------- 1305 1306 function Overlap (Left, Right : Set) return Boolean is 1307 begin 1308 return Set_Ops.Set_Overlap (Left, Right); 1309 end Overlap; 1310 1311 ------------ 1312 -- Parent -- 1313 ------------ 1314 1315 function Parent (Node : Node_Type) return Count_Type is 1316 begin 1317 return Node.Parent; 1318 end Parent; 1319 1320 -------------- 1321 -- Previous -- 1322 -------------- 1323 1324 function Previous (Container : Set; Position : Cursor) return Cursor is 1325 begin 1326 if Position = No_Element then 1327 return No_Element; 1328 end if; 1329 1330 if not Has_Element (Container, Position) then 1331 raise Constraint_Error; 1332 end if; 1333 1334 pragma Assert (Vet (Container, Position.Node), 1335 "bad cursor in Previous"); 1336 1337 declare 1338 Node : constant Count_Type := 1339 Tree_Operations.Previous (Container, Position.Node); 1340 begin 1341 return (if Node = 0 then No_Element else (Node => Node)); 1342 end; 1343 end Previous; 1344 1345 procedure Previous (Container : Set; Position : in out Cursor) is 1346 begin 1347 Position := Previous (Container, Position); 1348 end Previous; 1349 1350 ------------------- 1351 -- Query_Element -- 1352 ------------------- 1353 1354 procedure Query_Element 1355 (Container : in out Set; 1356 Position : Cursor; 1357 Process : not null access procedure (Element : Element_Type)) 1358 is 1359 begin 1360 if not Has_Element (Container, Position) then 1361 raise Constraint_Error with "Position cursor has no element"; 1362 end if; 1363 1364 pragma Assert (Vet (Container, Position.Node), 1365 "bad cursor in Query_Element"); 1366 1367 declare 1368 B : Natural renames Container.Busy; 1369 L : Natural renames Container.Lock; 1370 1371 begin 1372 B := B + 1; 1373 L := L + 1; 1374 1375 begin 1376 Process (Container.Nodes (Position.Node).Element); 1377 exception 1378 when others => 1379 L := L - 1; 1380 B := B - 1; 1381 raise; 1382 end; 1383 1384 L := L - 1; 1385 B := B - 1; 1386 end; 1387 end Query_Element; 1388 1389 ---------- 1390 -- Read -- 1391 ---------- 1392 1393 procedure Read 1394 (Stream : not null access Root_Stream_Type'Class; 1395 Container : out Set) 1396 is 1397 procedure Read_Element (Node : in out Node_Type); 1398 pragma Inline (Read_Element); 1399 1400 procedure Allocate is 1401 new Generic_Allocate (Read_Element); 1402 1403 procedure Read_Elements is 1404 new Tree_Operations.Generic_Read (Allocate); 1405 1406 ------------------ 1407 -- Read_Element -- 1408 ------------------ 1409 1410 procedure Read_Element (Node : in out Node_Type) is 1411 begin 1412 Element_Type'Read (Stream, Node.Element); 1413 end Read_Element; 1414 1415 -- Start of processing for Read 1416 1417 begin 1418 Read_Elements (Stream, Container); 1419 end Read; 1420 1421 procedure Read 1422 (Stream : not null access Root_Stream_Type'Class; 1423 Item : out Cursor) 1424 is 1425 begin 1426 raise Program_Error with "attempt to stream set cursor"; 1427 end Read; 1428 1429 ------------- 1430 -- Replace -- 1431 ------------- 1432 1433 procedure Replace (Container : in out Set; New_Item : Element_Type) is 1434 Node : constant Count_Type := Element_Keys.Find (Container, New_Item); 1435 1436 begin 1437 if Node = 0 then 1438 raise Constraint_Error with 1439 "attempt to replace element not in set"; 1440 end if; 1441 1442 if Container.Lock > 0 then 1443 raise Program_Error with 1444 "attempt to tamper with cursors (set is locked)"; 1445 end if; 1446 1447 Container.Nodes (Node).Element := New_Item; 1448 end Replace; 1449 1450 --------------------- 1451 -- Replace_Element -- 1452 --------------------- 1453 1454 procedure Replace_Element 1455 (Tree : in out Set; 1456 Node : Count_Type; 1457 Item : Element_Type) 1458 is 1459 pragma Assert (Node /= 0); 1460 1461 function New_Node return Count_Type; 1462 pragma Inline (New_Node); 1463 1464 procedure Local_Insert_Post is 1465 new Element_Keys.Generic_Insert_Post (New_Node); 1466 1467 procedure Local_Insert_Sans_Hint is 1468 new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); 1469 1470 procedure Local_Insert_With_Hint is 1471 new Element_Keys.Generic_Conditional_Insert_With_Hint 1472 (Local_Insert_Post, 1473 Local_Insert_Sans_Hint); 1474 1475 NN : Tree_Types.Nodes_Type renames Tree.Nodes; 1476 1477 -------------- 1478 -- New_Node -- 1479 -------------- 1480 1481 function New_Node return Count_Type is 1482 N : Node_Type renames NN (Node); 1483 begin 1484 N.Element := Item; 1485 N.Color := Red; 1486 N.Parent := 0; 1487 N.Right := 0; 1488 N.Left := 0; 1489 return Node; 1490 end New_Node; 1491 1492 Hint : Count_Type; 1493 Result : Count_Type; 1494 Inserted : Boolean; 1495 1496 -- Start of processing for Insert 1497 1498 begin 1499 if Item < NN (Node).Element 1500 or else NN (Node).Element < Item 1501 then 1502 null; 1503 1504 else 1505 if Tree.Lock > 0 then 1506 raise Program_Error with 1507 "attempt to tamper with cursors (set is locked)"; 1508 end if; 1509 1510 NN (Node).Element := Item; 1511 return; 1512 end if; 1513 1514 Hint := Element_Keys.Ceiling (Tree, Item); 1515 1516 if Hint = 0 then 1517 null; 1518 1519 elsif Item < NN (Hint).Element then 1520 if Hint = Node then 1521 if Tree.Lock > 0 then 1522 raise Program_Error with 1523 "attempt to tamper with cursors (set is locked)"; 1524 end if; 1525 1526 NN (Node).Element := Item; 1527 return; 1528 end if; 1529 1530 else 1531 pragma Assert (not (NN (Hint).Element < Item)); 1532 raise Program_Error with "attempt to replace existing element"; 1533 end if; 1534 1535 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit 1536 1537 Local_Insert_With_Hint 1538 (Tree => Tree, 1539 Position => Hint, 1540 Key => Item, 1541 Node => Result, 1542 Inserted => Inserted); 1543 1544 pragma Assert (Inserted); 1545 pragma Assert (Result = Node); 1546 end Replace_Element; 1547 1548 procedure Replace_Element 1549 (Container : in out Set; 1550 Position : Cursor; 1551 New_Item : Element_Type) 1552 is 1553 begin 1554 if not Has_Element (Container, Position) then 1555 raise Constraint_Error with 1556 "Position cursor has no element"; 1557 end if; 1558 1559 pragma Assert (Vet (Container, Position.Node), 1560 "bad cursor in Replace_Element"); 1561 1562 Replace_Element (Container, Position.Node, New_Item); 1563 end Replace_Element; 1564 1565 --------------------- 1566 -- Reverse_Iterate -- 1567 --------------------- 1568 1569 procedure Reverse_Iterate 1570 (Container : Set; 1571 Process : not null access procedure (Container : Set; 1572 Position : Cursor)) 1573 is 1574 procedure Process_Node (Node : Count_Type); 1575 pragma Inline (Process_Node); 1576 1577 procedure Local_Reverse_Iterate is 1578 new Tree_Operations.Generic_Reverse_Iteration (Process_Node); 1579 1580 ------------------ 1581 -- Process_Node -- 1582 ------------------ 1583 1584 procedure Process_Node (Node : Count_Type) is 1585 begin 1586 Process (Container, (Node => Node)); 1587 end Process_Node; 1588 1589 B : Natural renames Container'Unrestricted_Access.Busy; 1590 1591 -- Start of processing for Reverse_Iterate 1592 1593 begin 1594 B := B + 1; 1595 1596 begin 1597 Local_Reverse_Iterate (Container); 1598 exception 1599 when others => 1600 B := B - 1; 1601 raise; 1602 end; 1603 1604 B := B - 1; 1605 end Reverse_Iterate; 1606 1607 ----------- 1608 -- Right -- 1609 ----------- 1610 1611 function Right (Container : Set; Position : Cursor) return Set is 1612 Curs : Cursor := First (Container); 1613 C : Set (Container.Capacity) := Copy (Container, Container.Capacity); 1614 Node : Count_Type; 1615 1616 begin 1617 if Curs = No_Element then 1618 Clear (C); 1619 return C; 1620 end if; 1621 1622 if Position /= No_Element and not Has_Element (Container, Position) then 1623 raise Constraint_Error; 1624 end if; 1625 1626 while Curs.Node /= Position.Node loop 1627 Node := Curs.Node; 1628 Delete (C, Curs); 1629 Curs := Next (Container, (Node => Node)); 1630 end loop; 1631 1632 return C; 1633 end Right; 1634 1635 --------------- 1636 -- Right_Son -- 1637 --------------- 1638 1639 function Right_Son (Node : Node_Type) return Count_Type is 1640 begin 1641 return Node.Right; 1642 end Right_Son; 1643 1644 --------------- 1645 -- Set_Color -- 1646 --------------- 1647 1648 procedure Set_Color 1649 (Node : in out Node_Type; 1650 Color : Red_Black_Trees.Color_Type) 1651 is 1652 begin 1653 Node.Color := Color; 1654 end Set_Color; 1655 1656 -------------- 1657 -- Set_Left -- 1658 -------------- 1659 1660 procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is 1661 begin 1662 Node.Left := Left; 1663 end Set_Left; 1664 1665 ---------------- 1666 -- Set_Parent -- 1667 ---------------- 1668 1669 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is 1670 begin 1671 Node.Parent := Parent; 1672 end Set_Parent; 1673 1674 --------------- 1675 -- Set_Right -- 1676 --------------- 1677 1678 procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is 1679 begin 1680 Node.Right := Right; 1681 end Set_Right; 1682 1683 ------------------ 1684 -- Strict_Equal -- 1685 ------------------ 1686 1687 function Strict_Equal (Left, Right : Set) return Boolean is 1688 LNode : Count_Type := First (Left).Node; 1689 RNode : Count_Type := First (Right).Node; 1690 1691 begin 1692 if Length (Left) /= Length (Right) then 1693 return False; 1694 end if; 1695 1696 while LNode = RNode loop 1697 if LNode = 0 then 1698 return True; 1699 end if; 1700 1701 if Left.Nodes (LNode).Element /= 1702 Right.Nodes (RNode).Element then 1703 exit; 1704 end if; 1705 1706 LNode := Next (Left, LNode); 1707 RNode := Next (Right, RNode); 1708 end loop; 1709 1710 return False; 1711 end Strict_Equal; 1712 1713 -------------------------- 1714 -- Symmetric_Difference -- 1715 -------------------------- 1716 1717 procedure Symmetric_Difference (Target : in out Set; Source : Set) is 1718 begin 1719 Set_Ops.Set_Symmetric_Difference (Target, Source); 1720 end Symmetric_Difference; 1721 1722 function Symmetric_Difference (Left, Right : Set) return Set is 1723 begin 1724 if Left'Address = Right'Address then 1725 return Empty_Set; 1726 end if; 1727 1728 if Length (Right) = 0 then 1729 return Left.Copy; 1730 end if; 1731 1732 if Length (Left) = 0 then 1733 return Right.Copy; 1734 end if; 1735 1736 return S : Set (Length (Left) + Length (Right)) do 1737 Assign (S, Set_Ops.Set_Symmetric_Difference (Left, Right)); 1738 end return; 1739 end Symmetric_Difference; 1740 1741 ------------ 1742 -- To_Set -- 1743 ------------ 1744 1745 function To_Set (New_Item : Element_Type) return Set is 1746 Node : Count_Type; 1747 Inserted : Boolean; 1748 begin 1749 return S : Set (Capacity => 1) do 1750 Insert_Sans_Hint (S, New_Item, Node, Inserted); 1751 pragma Assert (Inserted); 1752 end return; 1753 end To_Set; 1754 1755 ----------- 1756 -- Union -- 1757 ----------- 1758 1759 procedure Union (Target : in out Set; Source : Set) is 1760 begin 1761 Set_Ops.Set_Union (Target, Source); 1762 end Union; 1763 1764 function Union (Left, Right : Set) return Set is 1765 begin 1766 if Left'Address = Right'Address then 1767 return Left.Copy; 1768 end if; 1769 1770 if Length (Left) = 0 then 1771 return Right.Copy; 1772 end if; 1773 1774 if Length (Right) = 0 then 1775 return Left.Copy; 1776 end if; 1777 1778 return S : Set (Length (Left) + Length (Right)) do 1779 S.Assign (Source => Left); 1780 S.Union (Right); 1781 end return; 1782 end Union; 1783 1784 ----------- 1785 -- Write -- 1786 ----------- 1787 1788 procedure Write 1789 (Stream : not null access Root_Stream_Type'Class; 1790 Container : Set) 1791 is 1792 procedure Write_Element 1793 (Stream : not null access Root_Stream_Type'Class; 1794 Node : Node_Type); 1795 pragma Inline (Write_Element); 1796 1797 procedure Write_Elements is 1798 new Tree_Operations.Generic_Write (Write_Element); 1799 1800 ------------------- 1801 -- Write_Element -- 1802 ------------------- 1803 1804 procedure Write_Element 1805 (Stream : not null access Root_Stream_Type'Class; 1806 Node : Node_Type) 1807 is 1808 begin 1809 Element_Type'Write (Stream, Node.Element); 1810 end Write_Element; 1811 1812 -- Start of processing for Write 1813 1814 begin 1815 Write_Elements (Stream, Container); 1816 end Write; 1817 1818 procedure Write 1819 (Stream : not null access Root_Stream_Type'Class; 1820 Item : Cursor) 1821 is 1822 begin 1823 raise Program_Error with "attempt to stream set cursor"; 1824 end Write; 1825 1826end Ada.Containers.Formal_Ordered_Sets; 1827