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