1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- ADA.CONTAINERS.BOUNDED_DOUBLY_LINKED_LISTS -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2004-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-- This unit was originally developed by Matthew J Heaney. -- 28------------------------------------------------------------------------------ 29 30with Ada.Finalization; use Ada.Finalization; 31 32with System; use type System.Address; 33 34package body Ada.Containers.Bounded_Doubly_Linked_Lists is 35 36 type Iterator is new Limited_Controlled and 37 List_Iterator_Interfaces.Reversible_Iterator with 38 record 39 Container : List_Access; 40 Node : Count_Type; 41 end record; 42 43 overriding procedure Finalize (Object : in out Iterator); 44 45 overriding function First (Object : Iterator) return Cursor; 46 overriding function Last (Object : Iterator) return Cursor; 47 48 overriding function Next 49 (Object : Iterator; 50 Position : Cursor) return Cursor; 51 52 overriding function Previous 53 (Object : Iterator; 54 Position : Cursor) return Cursor; 55 56 ----------------------- 57 -- Local Subprograms -- 58 ----------------------- 59 60 procedure Allocate 61 (Container : in out List; 62 New_Item : Element_Type; 63 New_Node : out Count_Type); 64 65 procedure Allocate 66 (Container : in out List; 67 New_Node : out Count_Type); 68 69 procedure Allocate 70 (Container : in out List; 71 Stream : not null access Root_Stream_Type'Class; 72 New_Node : out Count_Type); 73 74 procedure Free 75 (Container : in out List; 76 X : Count_Type); 77 78 procedure Insert_Internal 79 (Container : in out List; 80 Before : Count_Type; 81 New_Node : Count_Type); 82 83 function Vet (Position : Cursor) return Boolean; 84 -- Checks invariants of the cursor and its designated container, as a 85 -- simple way of detecting dangling references (see operation Free for a 86 -- description of the detection mechanism), returning True if all checks 87 -- pass. Invocations of Vet are used here as the argument of pragma Assert, 88 -- so the checks are performed only when assertions are enabled. 89 90 --------- 91 -- "=" -- 92 --------- 93 94 function "=" (Left, Right : List) return Boolean is 95 LN : Node_Array renames Left.Nodes; 96 RN : Node_Array renames Right.Nodes; 97 98 LI, RI : Count_Type; 99 100 begin 101 if Left'Address = Right'Address then 102 return True; 103 end if; 104 105 if Left.Length /= Right.Length then 106 return False; 107 end if; 108 109 LI := Left.First; 110 RI := Right.First; 111 for J in 1 .. Left.Length loop 112 if LN (LI).Element /= RN (RI).Element then 113 return False; 114 end if; 115 116 LI := LN (LI).Next; 117 RI := RN (RI).Next; 118 end loop; 119 120 return True; 121 end "="; 122 123 -------------- 124 -- Allocate -- 125 -------------- 126 127 procedure Allocate 128 (Container : in out List; 129 New_Item : Element_Type; 130 New_Node : out Count_Type) 131 is 132 N : Node_Array renames Container.Nodes; 133 134 begin 135 if Container.Free >= 0 then 136 New_Node := Container.Free; 137 138 -- We always perform the assignment first, before we change container 139 -- state, in order to defend against exceptions duration assignment. 140 141 N (New_Node).Element := New_Item; 142 Container.Free := N (New_Node).Next; 143 144 else 145 -- A negative free store value means that the links of the nodes in 146 -- the free store have not been initialized. In this case, the nodes 147 -- are physically contiguous in the array, starting at the index that 148 -- is the absolute value of the Container.Free, and continuing until 149 -- the end of the array (Nodes'Last). 150 151 New_Node := abs Container.Free; 152 153 -- As above, we perform this assignment first, before modifying any 154 -- container state. 155 156 N (New_Node).Element := New_Item; 157 Container.Free := Container.Free - 1; 158 end if; 159 end Allocate; 160 161 procedure Allocate 162 (Container : in out List; 163 Stream : not null access Root_Stream_Type'Class; 164 New_Node : out Count_Type) 165 is 166 N : Node_Array renames Container.Nodes; 167 168 begin 169 if Container.Free >= 0 then 170 New_Node := Container.Free; 171 172 -- We always perform the assignment first, before we change container 173 -- state, in order to defend against exceptions duration assignment. 174 175 Element_Type'Read (Stream, N (New_Node).Element); 176 Container.Free := N (New_Node).Next; 177 178 else 179 -- A negative free store value means that the links of the nodes in 180 -- the free store have not been initialized. In this case, the nodes 181 -- are physically contiguous in the array, starting at the index that 182 -- is the absolute value of the Container.Free, and continuing until 183 -- the end of the array (Nodes'Last). 184 185 New_Node := abs Container.Free; 186 187 -- As above, we perform this assignment first, before modifying any 188 -- container state. 189 190 Element_Type'Read (Stream, N (New_Node).Element); 191 Container.Free := Container.Free - 1; 192 end if; 193 end Allocate; 194 195 procedure Allocate 196 (Container : in out List; 197 New_Node : out Count_Type) 198 is 199 N : Node_Array renames Container.Nodes; 200 201 begin 202 if Container.Free >= 0 then 203 New_Node := Container.Free; 204 Container.Free := N (New_Node).Next; 205 206 else 207 -- As explained above, a negative free store value means that the 208 -- links for the nodes in the free store have not been initialized. 209 210 New_Node := abs Container.Free; 211 Container.Free := Container.Free - 1; 212 end if; 213 end Allocate; 214 215 ------------ 216 -- Append -- 217 ------------ 218 219 procedure Append 220 (Container : in out List; 221 New_Item : Element_Type; 222 Count : Count_Type := 1) 223 is 224 begin 225 Insert (Container, No_Element, New_Item, Count); 226 end Append; 227 228 ------------ 229 -- Assign -- 230 ------------ 231 232 procedure Assign (Target : in out List; Source : List) is 233 SN : Node_Array renames Source.Nodes; 234 J : Count_Type; 235 236 begin 237 if Target'Address = Source'Address then 238 return; 239 end if; 240 241 if Target.Capacity < Source.Length then 242 raise Capacity_Error -- ??? 243 with "Target capacity is less than Source length"; 244 end if; 245 246 Target.Clear; 247 248 J := Source.First; 249 while J /= 0 loop 250 Target.Append (SN (J).Element); 251 J := SN (J).Next; 252 end loop; 253 end Assign; 254 255 ----------- 256 -- Clear -- 257 ----------- 258 259 procedure Clear (Container : in out List) is 260 N : Node_Array renames Container.Nodes; 261 X : Count_Type; 262 263 begin 264 if Container.Length = 0 then 265 pragma Assert (Container.First = 0); 266 pragma Assert (Container.Last = 0); 267 pragma Assert (Container.Busy = 0); 268 pragma Assert (Container.Lock = 0); 269 return; 270 end if; 271 272 pragma Assert (Container.First >= 1); 273 pragma Assert (Container.Last >= 1); 274 pragma Assert (N (Container.First).Prev = 0); 275 pragma Assert (N (Container.Last).Next = 0); 276 277 if Container.Busy > 0 then 278 raise Program_Error with 279 "attempt to tamper with cursors (list is busy)"; 280 end if; 281 282 while Container.Length > 1 loop 283 X := Container.First; 284 pragma Assert (N (N (X).Next).Prev = Container.First); 285 286 Container.First := N (X).Next; 287 N (Container.First).Prev := 0; 288 289 Container.Length := Container.Length - 1; 290 291 Free (Container, X); 292 end loop; 293 294 X := Container.First; 295 pragma Assert (X = Container.Last); 296 297 Container.First := 0; 298 Container.Last := 0; 299 Container.Length := 0; 300 301 Free (Container, X); 302 end Clear; 303 304 ------------------------ 305 -- Constant_Reference -- 306 ------------------------ 307 308 function Constant_Reference 309 (Container : aliased List; 310 Position : Cursor) return Constant_Reference_Type 311 is 312 begin 313 if Position.Container = null then 314 raise Constraint_Error with "Position cursor has no element"; 315 end if; 316 317 if Position.Container /= Container'Unrestricted_Access then 318 raise Program_Error with 319 "Position cursor designates wrong container"; 320 end if; 321 322 pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); 323 324 declare 325 N : Node_Type renames Container.Nodes (Position.Node); 326 begin 327 return (Element => N.Element'Access); 328 end; 329 end Constant_Reference; 330 331 -------------- 332 -- Contains -- 333 -------------- 334 335 function Contains 336 (Container : List; 337 Item : Element_Type) return Boolean 338 is 339 begin 340 return Find (Container, Item) /= No_Element; 341 end Contains; 342 343 ---------- 344 -- Copy -- 345 ---------- 346 347 function Copy (Source : List; Capacity : Count_Type := 0) return List is 348 C : Count_Type; 349 350 begin 351 if Capacity = 0 then 352 C := Source.Length; 353 354 elsif Capacity >= Source.Length then 355 C := Capacity; 356 357 else 358 raise Capacity_Error with "Capacity value too small"; 359 end if; 360 361 return Target : List (Capacity => C) do 362 Assign (Target => Target, Source => Source); 363 end return; 364 end Copy; 365 366 ------------ 367 -- Delete -- 368 ------------ 369 370 procedure Delete 371 (Container : in out List; 372 Position : in out Cursor; 373 Count : Count_Type := 1) 374 is 375 N : Node_Array renames Container.Nodes; 376 X : Count_Type; 377 378 begin 379 if Position.Node = 0 then 380 raise Constraint_Error with 381 "Position cursor has no element"; 382 end if; 383 384 if Position.Container /= Container'Unrestricted_Access then 385 raise Program_Error with 386 "Position cursor designates wrong container"; 387 end if; 388 389 pragma Assert (Vet (Position), "bad cursor in Delete"); 390 pragma Assert (Container.First >= 1); 391 pragma Assert (Container.Last >= 1); 392 pragma Assert (N (Container.First).Prev = 0); 393 pragma Assert (N (Container.Last).Next = 0); 394 395 if Position.Node = Container.First then 396 Delete_First (Container, Count); 397 Position := No_Element; 398 return; 399 end if; 400 401 if Count = 0 then 402 Position := No_Element; 403 return; 404 end if; 405 406 if Container.Busy > 0 then 407 raise Program_Error with 408 "attempt to tamper with cursors (list is busy)"; 409 end if; 410 411 for Index in 1 .. Count loop 412 pragma Assert (Container.Length >= 2); 413 414 X := Position.Node; 415 Container.Length := Container.Length - 1; 416 417 if X = Container.Last then 418 Position := No_Element; 419 420 Container.Last := N (X).Prev; 421 N (Container.Last).Next := 0; 422 423 Free (Container, X); 424 return; 425 end if; 426 427 Position.Node := N (X).Next; 428 429 N (N (X).Next).Prev := N (X).Prev; 430 N (N (X).Prev).Next := N (X).Next; 431 432 Free (Container, X); 433 end loop; 434 435 Position := No_Element; 436 end Delete; 437 438 ------------------ 439 -- Delete_First -- 440 ------------------ 441 442 procedure Delete_First 443 (Container : in out List; 444 Count : Count_Type := 1) 445 is 446 N : Node_Array renames Container.Nodes; 447 X : Count_Type; 448 449 begin 450 if Count >= Container.Length then 451 Clear (Container); 452 return; 453 end if; 454 455 if Count = 0 then 456 return; 457 end if; 458 459 if Container.Busy > 0 then 460 raise Program_Error with 461 "attempt to tamper with cursors (list is busy)"; 462 end if; 463 464 for I in 1 .. Count loop 465 X := Container.First; 466 pragma Assert (N (N (X).Next).Prev = Container.First); 467 468 Container.First := N (X).Next; 469 N (Container.First).Prev := 0; 470 471 Container.Length := Container.Length - 1; 472 473 Free (Container, X); 474 end loop; 475 end Delete_First; 476 477 ----------------- 478 -- Delete_Last -- 479 ----------------- 480 481 procedure Delete_Last 482 (Container : in out List; 483 Count : Count_Type := 1) 484 is 485 N : Node_Array renames Container.Nodes; 486 X : Count_Type; 487 488 begin 489 if Count >= Container.Length then 490 Clear (Container); 491 return; 492 end if; 493 494 if Count = 0 then 495 return; 496 end if; 497 498 if Container.Busy > 0 then 499 raise Program_Error with 500 "attempt to tamper with cursors (list is busy)"; 501 end if; 502 503 for I in 1 .. Count loop 504 X := Container.Last; 505 pragma Assert (N (N (X).Prev).Next = Container.Last); 506 507 Container.Last := N (X).Prev; 508 N (Container.Last).Next := 0; 509 510 Container.Length := Container.Length - 1; 511 512 Free (Container, X); 513 end loop; 514 end Delete_Last; 515 516 ------------- 517 -- Element -- 518 ------------- 519 520 function Element (Position : Cursor) return Element_Type is 521 begin 522 if Position.Node = 0 then 523 raise Constraint_Error with 524 "Position cursor has no element"; 525 end if; 526 527 pragma Assert (Vet (Position), "bad cursor in Element"); 528 529 return Position.Container.Nodes (Position.Node).Element; 530 end Element; 531 532 -------------- 533 -- Finalize -- 534 -------------- 535 536 procedure Finalize (Object : in out Iterator) is 537 begin 538 if Object.Container /= null then 539 declare 540 B : Natural renames Object.Container.all.Busy; 541 542 begin 543 B := B - 1; 544 end; 545 end if; 546 end Finalize; 547 548 ---------- 549 -- Find -- 550 ---------- 551 552 function Find 553 (Container : List; 554 Item : Element_Type; 555 Position : Cursor := No_Element) return Cursor 556 is 557 Nodes : Node_Array renames Container.Nodes; 558 Node : Count_Type := Position.Node; 559 560 begin 561 if Node = 0 then 562 Node := Container.First; 563 564 else 565 if Position.Container /= Container'Unrestricted_Access then 566 raise Program_Error with 567 "Position cursor designates wrong container"; 568 end if; 569 570 pragma Assert (Vet (Position), "bad cursor in Find"); 571 end if; 572 573 while Node /= 0 loop 574 if Nodes (Node).Element = Item then 575 return Cursor'(Container'Unrestricted_Access, Node); 576 end if; 577 578 Node := Nodes (Node).Next; 579 end loop; 580 581 return No_Element; 582 end Find; 583 584 ----------- 585 -- First -- 586 ----------- 587 588 function First (Container : List) return Cursor is 589 begin 590 if Container.First = 0 then 591 return No_Element; 592 end if; 593 594 return Cursor'(Container'Unrestricted_Access, Container.First); 595 end First; 596 597 function First (Object : Iterator) return Cursor is 598 begin 599 -- The value of the iterator object's Node component influences the 600 -- behavior of the First (and Last) selector function. 601 602 -- When the Node component is 0, this means the iterator object was 603 -- constructed without a start expression, in which case the (forward) 604 -- iteration starts from the (logical) beginning of the entire sequence 605 -- of items (corresponding to Container.First, for a forward iterator). 606 607 -- Otherwise, this is iteration over a partial sequence of items. When 608 -- the Node component is positive, the iterator object was constructed 609 -- with a start expression, that specifies the position from which the 610 -- (forward) partial iteration begins. 611 612 if Object.Node = 0 then 613 return Bounded_Doubly_Linked_Lists.First (Object.Container.all); 614 else 615 return Cursor'(Object.Container, Object.Node); 616 end if; 617 end First; 618 619 ------------------- 620 -- First_Element -- 621 ------------------- 622 623 function First_Element (Container : List) return Element_Type is 624 begin 625 if Container.First = 0 then 626 raise Constraint_Error with "list is empty"; 627 end if; 628 629 return Container.Nodes (Container.First).Element; 630 end First_Element; 631 632 ---------- 633 -- Free -- 634 ---------- 635 636 procedure Free 637 (Container : in out List; 638 X : Count_Type) 639 is 640 pragma Assert (X > 0); 641 pragma Assert (X <= Container.Capacity); 642 643 N : Node_Array renames Container.Nodes; 644 pragma Assert (N (X).Prev >= 0); -- node is active 645 646 begin 647 -- The list container actually contains two lists: one for the "active" 648 -- nodes that contain elements that have been inserted onto the list, 649 -- and another for the "inactive" nodes for the free store. 650 651 -- We desire that merely declaring an object should have only minimal 652 -- cost; specially, we want to avoid having to initialize the free 653 -- store (to fill in the links), especially if the capacity is large. 654 655 -- The head of the free list is indicated by Container.Free. If its 656 -- value is non-negative, then the free store has been initialized in 657 -- the "normal" way: Container.Free points to the head of the list of 658 -- free (inactive) nodes, and the value 0 means the free list is empty. 659 -- Each node on the free list has been initialized to point to the next 660 -- free node (via its Next component), and the value 0 means that this 661 -- is the last free node. 662 663 -- If Container.Free is negative, then the links on the free store have 664 -- not been initialized. In this case the link values are implied: the 665 -- free store comprises the components of the node array started with 666 -- the absolute value of Container.Free, and continuing until the end of 667 -- the array (Nodes'Last). 668 669 -- If the list container is manipulated on one end only (for example if 670 -- the container were being used as a stack), then there is no need to 671 -- initialize the free store, since the inactive nodes are physically 672 -- contiguous (in fact, they lie immediately beyond the logical end 673 -- being manipulated). The only time we need to actually initialize the 674 -- nodes in the free store is if the node that becomes inactive is not 675 -- at the end of the list. The free store would then be discontiguous 676 -- and so its nodes would need to be linked in the traditional way. 677 678 -- ??? 679 -- It might be possible to perform an optimization here. Suppose that 680 -- the free store can be represented as having two parts: one comprising 681 -- the non-contiguous inactive nodes linked together in the normal way, 682 -- and the other comprising the contiguous inactive nodes (that are not 683 -- linked together, at the end of the nodes array). This would allow us 684 -- to never have to initialize the free store, except in a lazy way as 685 -- nodes become inactive. 686 687 -- When an element is deleted from the list container, its node becomes 688 -- inactive, and so we set its Prev component to a negative value, to 689 -- indicate that it is now inactive. This provides a useful way to 690 -- detect a dangling cursor reference (and which is used in Vet). 691 692 N (X).Prev := -1; -- Node is deallocated (not on active list) 693 694 if Container.Free >= 0 then 695 696 -- The free store has previously been initialized. All we need to 697 -- do here is link the newly-free'd node onto the free list. 698 699 N (X).Next := Container.Free; 700 Container.Free := X; 701 702 elsif X + 1 = abs Container.Free then 703 704 -- The free store has not been initialized, and the node becoming 705 -- inactive immediately precedes the start of the free store. All 706 -- we need to do is move the start of the free store back by one. 707 708 -- Note: initializing Next to zero is not strictly necessary but 709 -- seems cleaner and marginally safer. 710 711 N (X).Next := 0; 712 Container.Free := Container.Free + 1; 713 714 else 715 -- The free store has not been initialized, and the node becoming 716 -- inactive does not immediately precede the free store. Here we 717 -- first initialize the free store (meaning the links are given 718 -- values in the traditional way), and then link the newly-free'd 719 -- node onto the head of the free store. 720 721 -- ??? 722 -- See the comments above for an optimization opportunity. If the 723 -- next link for a node on the free store is negative, then this 724 -- means the remaining nodes on the free store are physically 725 -- contiguous, starting as the absolute value of that index value. 726 727 Container.Free := abs Container.Free; 728 729 if Container.Free > Container.Capacity then 730 Container.Free := 0; 731 732 else 733 for I in Container.Free .. Container.Capacity - 1 loop 734 N (I).Next := I + 1; 735 end loop; 736 737 N (Container.Capacity).Next := 0; 738 end if; 739 740 N (X).Next := Container.Free; 741 Container.Free := X; 742 end if; 743 end Free; 744 745 --------------------- 746 -- Generic_Sorting -- 747 --------------------- 748 749 package body Generic_Sorting is 750 751 --------------- 752 -- Is_Sorted -- 753 --------------- 754 755 function Is_Sorted (Container : List) return Boolean is 756 Nodes : Node_Array renames Container.Nodes; 757 Node : Count_Type := Container.First; 758 759 begin 760 for J in 2 .. Container.Length loop 761 if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then 762 return False; 763 end if; 764 765 Node := Nodes (Node).Next; 766 end loop; 767 768 return True; 769 end Is_Sorted; 770 771 ----------- 772 -- Merge -- 773 ----------- 774 775 procedure Merge 776 (Target : in out List; 777 Source : in out List) 778 is 779 LN : Node_Array renames Target.Nodes; 780 RN : Node_Array renames Source.Nodes; 781 LI, RI : Cursor; 782 783 begin 784 785 -- The semantics of Merge changed slightly per AI05-0021. It was 786 -- originally the case that if Target and Source denoted the same 787 -- container object, then the GNAT implementation of Merge did 788 -- nothing. However, it was argued that RM05 did not precisely 789 -- specify the semantics for this corner case. The decision of the 790 -- ARG was that if Target and Source denote the same non-empty 791 -- container object, then Program_Error is raised. 792 793 if Source.Is_Empty then 794 return; 795 end if; 796 797 if Target'Address = Source'Address then 798 raise Program_Error with 799 "Target and Source denote same non-empty container"; 800 end if; 801 802 if Target.Busy > 0 then 803 raise Program_Error with 804 "attempt to tamper with cursors of Target (list is busy)"; 805 end if; 806 807 if Source.Busy > 0 then 808 raise Program_Error with 809 "attempt to tamper with cursors of Source (list is busy)"; 810 end if; 811 812 LI := First (Target); 813 RI := First (Source); 814 while RI.Node /= 0 loop 815 pragma Assert (RN (RI.Node).Next = 0 816 or else not (RN (RN (RI.Node).Next).Element < 817 RN (RI.Node).Element)); 818 819 if LI.Node = 0 then 820 Splice (Target, No_Element, Source); 821 return; 822 end if; 823 824 pragma Assert (LN (LI.Node).Next = 0 825 or else not (LN (LN (LI.Node).Next).Element < 826 LN (LI.Node).Element)); 827 828 if RN (RI.Node).Element < LN (LI.Node).Element then 829 declare 830 RJ : Cursor := RI; 831 begin 832 RI.Node := RN (RI.Node).Next; 833 Splice (Target, LI, Source, RJ); 834 end; 835 836 else 837 LI.Node := LN (LI.Node).Next; 838 end if; 839 end loop; 840 end Merge; 841 842 ---------- 843 -- Sort -- 844 ---------- 845 846 procedure Sort (Container : in out List) is 847 N : Node_Array renames Container.Nodes; 848 849 procedure Partition (Pivot, Back : Count_Type); 850 -- What does this do ??? 851 852 procedure Sort (Front, Back : Count_Type); 853 -- Internal procedure, what does it do??? rename it??? 854 855 --------------- 856 -- Partition -- 857 --------------- 858 859 procedure Partition (Pivot, Back : Count_Type) is 860 Node : Count_Type; 861 862 begin 863 Node := N (Pivot).Next; 864 while Node /= Back loop 865 if N (Node).Element < N (Pivot).Element then 866 declare 867 Prev : constant Count_Type := N (Node).Prev; 868 Next : constant Count_Type := N (Node).Next; 869 870 begin 871 N (Prev).Next := Next; 872 873 if Next = 0 then 874 Container.Last := Prev; 875 else 876 N (Next).Prev := Prev; 877 end if; 878 879 N (Node).Next := Pivot; 880 N (Node).Prev := N (Pivot).Prev; 881 882 N (Pivot).Prev := Node; 883 884 if N (Node).Prev = 0 then 885 Container.First := Node; 886 else 887 N (N (Node).Prev).Next := Node; 888 end if; 889 890 Node := Next; 891 end; 892 893 else 894 Node := N (Node).Next; 895 end if; 896 end loop; 897 end Partition; 898 899 ---------- 900 -- Sort -- 901 ---------- 902 903 procedure Sort (Front, Back : Count_Type) is 904 Pivot : constant Count_Type := 905 (if Front = 0 then Container.First else N (Front).Next); 906 begin 907 if Pivot /= Back then 908 Partition (Pivot, Back); 909 Sort (Front, Pivot); 910 Sort (Pivot, Back); 911 end if; 912 end Sort; 913 914 -- Start of processing for Sort 915 916 begin 917 if Container.Length <= 1 then 918 return; 919 end if; 920 921 pragma Assert (N (Container.First).Prev = 0); 922 pragma Assert (N (Container.Last).Next = 0); 923 924 if Container.Busy > 0 then 925 raise Program_Error with 926 "attempt to tamper with cursors (list is busy)"; 927 end if; 928 929 Sort (Front => 0, Back => 0); 930 931 pragma Assert (N (Container.First).Prev = 0); 932 pragma Assert (N (Container.Last).Next = 0); 933 end Sort; 934 935 end Generic_Sorting; 936 937 ----------------- 938 -- Has_Element -- 939 ----------------- 940 941 function Has_Element (Position : Cursor) return Boolean is 942 begin 943 pragma Assert (Vet (Position), "bad cursor in Has_Element"); 944 return Position.Node /= 0; 945 end Has_Element; 946 947 ------------ 948 -- Insert -- 949 ------------ 950 951 procedure Insert 952 (Container : in out List; 953 Before : Cursor; 954 New_Item : Element_Type; 955 Position : out Cursor; 956 Count : Count_Type := 1) 957 is 958 New_Node : Count_Type; 959 960 begin 961 if Before.Container /= null then 962 if Before.Container /= Container'Unrestricted_Access then 963 raise Program_Error with 964 "Before cursor designates wrong list"; 965 end if; 966 967 pragma Assert (Vet (Before), "bad cursor in Insert"); 968 end if; 969 970 if Count = 0 then 971 Position := Before; 972 return; 973 end if; 974 975 if Container.Length > Container.Capacity - Count then 976 raise Constraint_Error with "new length exceeds capacity"; 977 end if; 978 979 if Container.Busy > 0 then 980 raise Program_Error with 981 "attempt to tamper with cursors (list is busy)"; 982 end if; 983 984 Allocate (Container, New_Item, New_Node); 985 Insert_Internal (Container, Before.Node, New_Node => New_Node); 986 Position := Cursor'(Container'Unchecked_Access, Node => New_Node); 987 988 for Index in Count_Type'(2) .. Count loop 989 Allocate (Container, New_Item, New_Node => New_Node); 990 Insert_Internal (Container, Before.Node, New_Node => New_Node); 991 end loop; 992 end Insert; 993 994 procedure Insert 995 (Container : in out List; 996 Before : Cursor; 997 New_Item : Element_Type; 998 Count : Count_Type := 1) 999 is 1000 Position : Cursor; 1001 pragma Unreferenced (Position); 1002 begin 1003 Insert (Container, Before, New_Item, Position, Count); 1004 end Insert; 1005 1006 procedure Insert 1007 (Container : in out List; 1008 Before : Cursor; 1009 Position : out Cursor; 1010 Count : Count_Type := 1) 1011 is 1012 New_Node : Count_Type; 1013 1014 begin 1015 if Before.Container /= null then 1016 if Before.Container /= Container'Unrestricted_Access then 1017 raise Program_Error with 1018 "Before cursor designates wrong list"; 1019 end if; 1020 1021 pragma Assert (Vet (Before), "bad cursor in Insert"); 1022 end if; 1023 1024 if Count = 0 then 1025 Position := Before; 1026 return; 1027 end if; 1028 1029 if Container.Length > Container.Capacity - Count then 1030 raise Constraint_Error with "new length exceeds capacity"; 1031 end if; 1032 1033 if Container.Busy > 0 then 1034 raise Program_Error with 1035 "attempt to tamper with cursors (list is busy)"; 1036 end if; 1037 1038 Allocate (Container, New_Node => New_Node); 1039 Insert_Internal (Container, Before.Node, New_Node); 1040 Position := Cursor'(Container'Unchecked_Access, New_Node); 1041 1042 for Index in Count_Type'(2) .. Count loop 1043 Allocate (Container, New_Node => New_Node); 1044 Insert_Internal (Container, Before.Node, New_Node); 1045 end loop; 1046 end Insert; 1047 1048 --------------------- 1049 -- Insert_Internal -- 1050 --------------------- 1051 1052 procedure Insert_Internal 1053 (Container : in out List; 1054 Before : Count_Type; 1055 New_Node : Count_Type) 1056 is 1057 N : Node_Array renames Container.Nodes; 1058 1059 begin 1060 if Container.Length = 0 then 1061 pragma Assert (Before = 0); 1062 pragma Assert (Container.First = 0); 1063 pragma Assert (Container.Last = 0); 1064 1065 Container.First := New_Node; 1066 N (Container.First).Prev := 0; 1067 1068 Container.Last := New_Node; 1069 N (Container.Last).Next := 0; 1070 1071 -- Before = zero means append 1072 1073 elsif Before = 0 then 1074 pragma Assert (N (Container.Last).Next = 0); 1075 1076 N (Container.Last).Next := New_Node; 1077 N (New_Node).Prev := Container.Last; 1078 1079 Container.Last := New_Node; 1080 N (Container.Last).Next := 0; 1081 1082 -- Before = Container.First means prepend 1083 1084 elsif Before = Container.First then 1085 pragma Assert (N (Container.First).Prev = 0); 1086 1087 N (Container.First).Prev := New_Node; 1088 N (New_Node).Next := Container.First; 1089 1090 Container.First := New_Node; 1091 N (Container.First).Prev := 0; 1092 1093 else 1094 pragma Assert (N (Container.First).Prev = 0); 1095 pragma Assert (N (Container.Last).Next = 0); 1096 1097 N (New_Node).Next := Before; 1098 N (New_Node).Prev := N (Before).Prev; 1099 1100 N (N (Before).Prev).Next := New_Node; 1101 N (Before).Prev := New_Node; 1102 end if; 1103 1104 Container.Length := Container.Length + 1; 1105 end Insert_Internal; 1106 1107 -------------- 1108 -- Is_Empty -- 1109 -------------- 1110 1111 function Is_Empty (Container : List) return Boolean is 1112 begin 1113 return Container.Length = 0; 1114 end Is_Empty; 1115 1116 ------------- 1117 -- Iterate -- 1118 ------------- 1119 1120 procedure Iterate 1121 (Container : List; 1122 Process : not null access procedure (Position : Cursor)) 1123 is 1124 B : Natural renames Container'Unrestricted_Access.all.Busy; 1125 Node : Count_Type := Container.First; 1126 1127 begin 1128 B := B + 1; 1129 1130 begin 1131 while Node /= 0 loop 1132 Process (Cursor'(Container'Unrestricted_Access, Node)); 1133 Node := Container.Nodes (Node).Next; 1134 end loop; 1135 1136 exception 1137 when others => 1138 B := B - 1; 1139 raise; 1140 end; 1141 1142 B := B - 1; 1143 end Iterate; 1144 1145 function Iterate 1146 (Container : List) 1147 return List_Iterator_Interfaces.Reversible_Iterator'Class 1148 is 1149 B : Natural renames Container'Unrestricted_Access.all.Busy; 1150 1151 begin 1152 -- The value of the Node component influences the behavior of the First 1153 -- and Last selector functions of the iterator object. When the Node 1154 -- component is 0 (as is the case here), this means the iterator 1155 -- object was constructed without a start expression. This is a 1156 -- complete iterator, meaning that the iteration starts from the 1157 -- (logical) beginning of the sequence of items. 1158 1159 -- Note: For a forward iterator, Container.First is the beginning, and 1160 -- for a reverse iterator, Container.Last is the beginning. 1161 1162 return It : constant Iterator := 1163 Iterator'(Limited_Controlled with 1164 Container => Container'Unrestricted_Access, 1165 Node => 0) 1166 do 1167 B := B + 1; 1168 end return; 1169 end Iterate; 1170 1171 function Iterate 1172 (Container : List; 1173 Start : Cursor) 1174 return List_Iterator_Interfaces.Reversible_Iterator'class 1175 is 1176 B : Natural renames Container'Unrestricted_Access.all.Busy; 1177 1178 begin 1179 -- It was formerly the case that when Start = No_Element, the partial 1180 -- iterator was defined to behave the same as for a complete iterator, 1181 -- and iterate over the entire sequence of items. However, those 1182 -- semantics were unintuitive and arguably error-prone (it is too easy 1183 -- to accidentally create an endless loop), and so they were changed, 1184 -- per the ARG meeting in Denver on 2011/11. However, there was no 1185 -- consensus about what positive meaning this corner case should have, 1186 -- and so it was decided to simply raise an exception. This does imply, 1187 -- however, that it is not possible to use a partial iterator to specify 1188 -- an empty sequence of items. 1189 1190 if Start = No_Element then 1191 raise Constraint_Error with 1192 "Start position for iterator equals No_Element"; 1193 end if; 1194 1195 if Start.Container /= Container'Unrestricted_Access then 1196 raise Program_Error with 1197 "Start cursor of Iterate designates wrong list"; 1198 end if; 1199 1200 pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); 1201 1202 -- The value of the Node component influences the behavior of the First 1203 -- and Last selector functions of the iterator object. When the Node 1204 -- component is positive (as is the case here), it means that this 1205 -- is a partial iteration, over a subset of the complete sequence of 1206 -- items. The iterator object was constructed with a start expression, 1207 -- indicating the position from which the iteration begins. Note that 1208 -- the start position has the same value irrespective of whether this 1209 -- is a forward or reverse iteration. 1210 1211 return It : constant Iterator := 1212 Iterator'(Limited_Controlled with 1213 Container => Container'Unrestricted_Access, 1214 Node => Start.Node) 1215 do 1216 B := B + 1; 1217 end return; 1218 end Iterate; 1219 1220 ---------- 1221 -- Last -- 1222 ---------- 1223 1224 function Last (Container : List) return Cursor is 1225 begin 1226 if Container.Last = 0 then 1227 return No_Element; 1228 end if; 1229 1230 return Cursor'(Container'Unrestricted_Access, Container.Last); 1231 end Last; 1232 1233 function Last (Object : Iterator) return Cursor is 1234 begin 1235 -- The value of the iterator object's Node component influences the 1236 -- behavior of the Last (and First) selector function. 1237 1238 -- When the Node component is 0, this means the iterator object was 1239 -- constructed without a start expression, in which case the (reverse) 1240 -- iteration starts from the (logical) beginning of the entire sequence 1241 -- (corresponding to Container.Last, for a reverse iterator). 1242 1243 -- Otherwise, this is iteration over a partial sequence of items. When 1244 -- the Node component is positive, the iterator object was constructed 1245 -- with a start expression, that specifies the position from which the 1246 -- (reverse) partial iteration begins. 1247 1248 if Object.Node = 0 then 1249 return Bounded_Doubly_Linked_Lists.Last (Object.Container.all); 1250 else 1251 return Cursor'(Object.Container, Object.Node); 1252 end if; 1253 end Last; 1254 1255 ------------------ 1256 -- Last_Element -- 1257 ------------------ 1258 1259 function Last_Element (Container : List) return Element_Type is 1260 begin 1261 if Container.Last = 0 then 1262 raise Constraint_Error with "list is empty"; 1263 end if; 1264 1265 return Container.Nodes (Container.Last).Element; 1266 end Last_Element; 1267 1268 ------------ 1269 -- Length -- 1270 ------------ 1271 1272 function Length (Container : List) return Count_Type is 1273 begin 1274 return Container.Length; 1275 end Length; 1276 1277 ---------- 1278 -- Move -- 1279 ---------- 1280 1281 procedure Move 1282 (Target : in out List; 1283 Source : in out List) 1284 is 1285 N : Node_Array renames Source.Nodes; 1286 X : Count_Type; 1287 1288 begin 1289 if Target'Address = Source'Address then 1290 return; 1291 end if; 1292 1293 if Target.Capacity < Source.Length then 1294 raise Capacity_Error with "Source length exceeds Target capacity"; 1295 end if; 1296 1297 if Source.Busy > 0 then 1298 raise Program_Error with 1299 "attempt to tamper with cursors of Source (list is busy)"; 1300 end if; 1301 1302 -- Clear target, note that this checks busy bits of Target 1303 1304 Clear (Target); 1305 1306 while Source.Length > 1 loop 1307 pragma Assert (Source.First in 1 .. Source.Capacity); 1308 pragma Assert (Source.Last /= Source.First); 1309 pragma Assert (N (Source.First).Prev = 0); 1310 pragma Assert (N (Source.Last).Next = 0); 1311 1312 -- Copy first element from Source to Target 1313 1314 X := Source.First; 1315 Append (Target, N (X).Element); 1316 1317 -- Unlink first node of Source 1318 1319 Source.First := N (X).Next; 1320 N (Source.First).Prev := 0; 1321 1322 Source.Length := Source.Length - 1; 1323 1324 -- The representation invariants for Source have been restored. It is 1325 -- now safe to free the unlinked node, without fear of corrupting the 1326 -- active links of Source. 1327 1328 -- Note that the algorithm we use here models similar algorithms used 1329 -- in the unbounded form of the doubly-linked list container. In that 1330 -- case, Free is an instantation of Unchecked_Deallocation, which can 1331 -- fail (because PE will be raised if controlled Finalize fails), so 1332 -- we must defer the call until the last step. Here in the bounded 1333 -- form, Free merely links the node we have just "deallocated" onto a 1334 -- list of inactive nodes, so technically Free cannot fail. However, 1335 -- for consistency, we handle Free the same way here as we do for the 1336 -- unbounded form, with the pessimistic assumption that it can fail. 1337 1338 Free (Source, X); 1339 end loop; 1340 1341 if Source.Length = 1 then 1342 pragma Assert (Source.First in 1 .. Source.Capacity); 1343 pragma Assert (Source.Last = Source.First); 1344 pragma Assert (N (Source.First).Prev = 0); 1345 pragma Assert (N (Source.Last).Next = 0); 1346 1347 -- Copy element from Source to Target 1348 1349 X := Source.First; 1350 Append (Target, N (X).Element); 1351 1352 -- Unlink node of Source 1353 1354 Source.First := 0; 1355 Source.Last := 0; 1356 Source.Length := 0; 1357 1358 -- Return the unlinked node to the free store 1359 1360 Free (Source, X); 1361 end if; 1362 end Move; 1363 1364 ---------- 1365 -- Next -- 1366 ---------- 1367 1368 procedure Next (Position : in out Cursor) is 1369 begin 1370 Position := Next (Position); 1371 end Next; 1372 1373 function Next (Position : Cursor) return Cursor is 1374 begin 1375 if Position.Node = 0 then 1376 return No_Element; 1377 end if; 1378 1379 pragma Assert (Vet (Position), "bad cursor in Next"); 1380 1381 declare 1382 Nodes : Node_Array renames Position.Container.Nodes; 1383 Node : constant Count_Type := Nodes (Position.Node).Next; 1384 1385 begin 1386 if Node = 0 then 1387 return No_Element; 1388 end if; 1389 1390 return Cursor'(Position.Container, Node); 1391 end; 1392 end Next; 1393 1394 function Next 1395 (Object : Iterator; 1396 Position : Cursor) return Cursor 1397 is 1398 begin 1399 if Position.Container = null then 1400 return No_Element; 1401 end if; 1402 1403 if Position.Container /= Object.Container then 1404 raise Program_Error with 1405 "Position cursor of Next designates wrong list"; 1406 end if; 1407 1408 return Next (Position); 1409 end Next; 1410 1411 ------------- 1412 -- Prepend -- 1413 ------------- 1414 1415 procedure Prepend 1416 (Container : in out List; 1417 New_Item : Element_Type; 1418 Count : Count_Type := 1) 1419 is 1420 begin 1421 Insert (Container, First (Container), New_Item, Count); 1422 end Prepend; 1423 1424 -------------- 1425 -- Previous -- 1426 -------------- 1427 1428 procedure Previous (Position : in out Cursor) is 1429 begin 1430 Position := Previous (Position); 1431 end Previous; 1432 1433 function Previous (Position : Cursor) return Cursor is 1434 begin 1435 if Position.Node = 0 then 1436 return No_Element; 1437 end if; 1438 1439 pragma Assert (Vet (Position), "bad cursor in Previous"); 1440 1441 declare 1442 Nodes : Node_Array renames Position.Container.Nodes; 1443 Node : constant Count_Type := Nodes (Position.Node).Prev; 1444 begin 1445 if Node = 0 then 1446 return No_Element; 1447 end if; 1448 1449 return Cursor'(Position.Container, Node); 1450 end; 1451 end Previous; 1452 1453 function Previous 1454 (Object : Iterator; 1455 Position : Cursor) return Cursor 1456 is 1457 begin 1458 if Position.Container = null then 1459 return No_Element; 1460 end if; 1461 1462 if Position.Container /= Object.Container then 1463 raise Program_Error with 1464 "Position cursor of Previous designates wrong list"; 1465 end if; 1466 1467 return Previous (Position); 1468 end Previous; 1469 1470 ------------------- 1471 -- Query_Element -- 1472 ------------------- 1473 1474 procedure Query_Element 1475 (Position : Cursor; 1476 Process : not null access procedure (Element : Element_Type)) 1477 is 1478 begin 1479 if Position.Node = 0 then 1480 raise Constraint_Error with 1481 "Position cursor has no element"; 1482 end if; 1483 1484 pragma Assert (Vet (Position), "bad cursor in Query_Element"); 1485 1486 declare 1487 C : List renames Position.Container.all'Unrestricted_Access.all; 1488 B : Natural renames C.Busy; 1489 L : Natural renames C.Lock; 1490 1491 begin 1492 B := B + 1; 1493 L := L + 1; 1494 1495 declare 1496 N : Node_Type renames C.Nodes (Position.Node); 1497 begin 1498 Process (N.Element); 1499 exception 1500 when others => 1501 L := L - 1; 1502 B := B - 1; 1503 raise; 1504 end; 1505 1506 L := L - 1; 1507 B := B - 1; 1508 end; 1509 end Query_Element; 1510 1511 ---------- 1512 -- Read -- 1513 ---------- 1514 1515 procedure Read 1516 (Stream : not null access Root_Stream_Type'Class; 1517 Item : out List) 1518 is 1519 N : Count_Type'Base; 1520 X : Count_Type; 1521 1522 begin 1523 Clear (Item); 1524 Count_Type'Base'Read (Stream, N); 1525 1526 if N < 0 then 1527 raise Program_Error with "bad list length (corrupt stream)"; 1528 end if; 1529 1530 if N = 0 then 1531 return; 1532 end if; 1533 1534 if N > Item.Capacity then 1535 raise Constraint_Error with "length exceeds capacity"; 1536 end if; 1537 1538 for Idx in 1 .. N loop 1539 Allocate (Item, Stream, New_Node => X); 1540 Insert_Internal (Item, Before => 0, New_Node => X); 1541 end loop; 1542 end Read; 1543 1544 procedure Read 1545 (Stream : not null access Root_Stream_Type'Class; 1546 Item : out Cursor) 1547 is 1548 begin 1549 raise Program_Error with "attempt to stream list cursor"; 1550 end Read; 1551 1552 procedure Read 1553 (Stream : not null access Root_Stream_Type'Class; 1554 Item : out Reference_Type) 1555 is 1556 begin 1557 raise Program_Error with "attempt to stream reference"; 1558 end Read; 1559 1560 procedure Read 1561 (Stream : not null access Root_Stream_Type'Class; 1562 Item : out Constant_Reference_Type) 1563 is 1564 begin 1565 raise Program_Error with "attempt to stream reference"; 1566 end Read; 1567 1568 --------------- 1569 -- Reference -- 1570 --------------- 1571 1572 function Reference 1573 (Container : aliased in out List; 1574 Position : Cursor) return Reference_Type 1575 is 1576 begin 1577 if Position.Container = null then 1578 raise Constraint_Error with "Position cursor has no element"; 1579 end if; 1580 1581 if Position.Container /= Container'Unrestricted_Access then 1582 raise Program_Error with 1583 "Position cursor designates wrong container"; 1584 end if; 1585 1586 pragma Assert (Vet (Position), "bad cursor in function Reference"); 1587 1588 declare 1589 N : Node_Type renames Container.Nodes (Position.Node); 1590 begin 1591 return (Element => N.Element'Access); 1592 end; 1593 end Reference; 1594 1595 --------------------- 1596 -- Replace_Element -- 1597 --------------------- 1598 1599 procedure Replace_Element 1600 (Container : in out List; 1601 Position : Cursor; 1602 New_Item : Element_Type) 1603 is 1604 begin 1605 if Position.Container = null then 1606 raise Constraint_Error with "Position cursor has no element"; 1607 end if; 1608 1609 if Position.Container /= Container'Unchecked_Access then 1610 raise Program_Error with 1611 "Position cursor designates wrong container"; 1612 end if; 1613 1614 if Container.Lock > 0 then 1615 raise Program_Error with 1616 "attempt to tamper with elements (list is locked)"; 1617 end if; 1618 1619 pragma Assert (Vet (Position), "bad cursor in Replace_Element"); 1620 1621 Container.Nodes (Position.Node).Element := New_Item; 1622 end Replace_Element; 1623 1624 ---------------------- 1625 -- Reverse_Elements -- 1626 ---------------------- 1627 1628 procedure Reverse_Elements (Container : in out List) is 1629 N : Node_Array renames Container.Nodes; 1630 I : Count_Type := Container.First; 1631 J : Count_Type := Container.Last; 1632 1633 procedure Swap (L, R : Count_Type); 1634 1635 ---------- 1636 -- Swap -- 1637 ---------- 1638 1639 procedure Swap (L, R : Count_Type) is 1640 LN : constant Count_Type := N (L).Next; 1641 LP : constant Count_Type := N (L).Prev; 1642 1643 RN : constant Count_Type := N (R).Next; 1644 RP : constant Count_Type := N (R).Prev; 1645 1646 begin 1647 if LP /= 0 then 1648 N (LP).Next := R; 1649 end if; 1650 1651 if RN /= 0 then 1652 N (RN).Prev := L; 1653 end if; 1654 1655 N (L).Next := RN; 1656 N (R).Prev := LP; 1657 1658 if LN = R then 1659 pragma Assert (RP = L); 1660 1661 N (L).Prev := R; 1662 N (R).Next := L; 1663 1664 else 1665 N (L).Prev := RP; 1666 N (RP).Next := L; 1667 1668 N (R).Next := LN; 1669 N (LN).Prev := R; 1670 end if; 1671 end Swap; 1672 1673 -- Start of processing for Reverse_Elements 1674 1675 begin 1676 if Container.Length <= 1 then 1677 return; 1678 end if; 1679 1680 pragma Assert (N (Container.First).Prev = 0); 1681 pragma Assert (N (Container.Last).Next = 0); 1682 1683 if Container.Busy > 0 then 1684 raise Program_Error with 1685 "attempt to tamper with cursors (list is busy)"; 1686 end if; 1687 1688 Container.First := J; 1689 Container.Last := I; 1690 loop 1691 Swap (L => I, R => J); 1692 1693 J := N (J).Next; 1694 exit when I = J; 1695 1696 I := N (I).Prev; 1697 exit when I = J; 1698 1699 Swap (L => J, R => I); 1700 1701 I := N (I).Next; 1702 exit when I = J; 1703 1704 J := N (J).Prev; 1705 exit when I = J; 1706 end loop; 1707 1708 pragma Assert (N (Container.First).Prev = 0); 1709 pragma Assert (N (Container.Last).Next = 0); 1710 end Reverse_Elements; 1711 1712 ------------------ 1713 -- Reverse_Find -- 1714 ------------------ 1715 1716 function Reverse_Find 1717 (Container : List; 1718 Item : Element_Type; 1719 Position : Cursor := No_Element) return Cursor 1720 is 1721 Node : Count_Type := Position.Node; 1722 1723 begin 1724 if Node = 0 then 1725 Node := Container.Last; 1726 1727 else 1728 if Position.Container /= Container'Unrestricted_Access then 1729 raise Program_Error with 1730 "Position cursor designates wrong container"; 1731 end if; 1732 1733 pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); 1734 end if; 1735 1736 while Node /= 0 loop 1737 if Container.Nodes (Node).Element = Item then 1738 return Cursor'(Container'Unrestricted_Access, Node); 1739 end if; 1740 1741 Node := Container.Nodes (Node).Prev; 1742 end loop; 1743 1744 return No_Element; 1745 end Reverse_Find; 1746 1747 --------------------- 1748 -- Reverse_Iterate -- 1749 --------------------- 1750 1751 procedure Reverse_Iterate 1752 (Container : List; 1753 Process : not null access procedure (Position : Cursor)) 1754 is 1755 C : List renames Container'Unrestricted_Access.all; 1756 B : Natural renames C.Busy; 1757 1758 Node : Count_Type := Container.Last; 1759 1760 begin 1761 B := B + 1; 1762 1763 begin 1764 while Node /= 0 loop 1765 Process (Cursor'(Container'Unrestricted_Access, Node)); 1766 Node := Container.Nodes (Node).Prev; 1767 end loop; 1768 1769 exception 1770 when others => 1771 B := B - 1; 1772 raise; 1773 end; 1774 1775 B := B - 1; 1776 end Reverse_Iterate; 1777 1778 ------------ 1779 -- Splice -- 1780 ------------ 1781 1782 procedure Splice 1783 (Target : in out List; 1784 Before : Cursor; 1785 Source : in out List) 1786 is 1787 begin 1788 if Before.Container /= null then 1789 if Before.Container /= Target'Unrestricted_Access then 1790 raise Program_Error with 1791 "Before cursor designates wrong container"; 1792 end if; 1793 1794 pragma Assert (Vet (Before), "bad cursor in Splice"); 1795 end if; 1796 1797 if Target'Address = Source'Address 1798 or else Source.Length = 0 1799 then 1800 return; 1801 end if; 1802 1803 pragma Assert (Source.Nodes (Source.First).Prev = 0); 1804 pragma Assert (Source.Nodes (Source.Last).Next = 0); 1805 1806 if Target.Length > Count_Type'Last - Source.Length then 1807 raise Constraint_Error with "new length exceeds maximum"; 1808 end if; 1809 1810 if Target.Length + Source.Length > Target.Capacity then 1811 raise Capacity_Error with "new length exceeds target capacity"; 1812 end if; 1813 1814 if Target.Busy > 0 then 1815 raise Program_Error with 1816 "attempt to tamper with cursors of Target (list is busy)"; 1817 end if; 1818 1819 if Source.Busy > 0 then 1820 raise Program_Error with 1821 "attempt to tamper with cursors of Source (list is busy)"; 1822 end if; 1823 1824 while not Is_Empty (Source) loop 1825 Insert (Target, Before, Source.Nodes (Source.First).Element); 1826 Delete_First (Source); 1827 end loop; 1828 end Splice; 1829 1830 procedure Splice 1831 (Container : in out List; 1832 Before : Cursor; 1833 Position : Cursor) 1834 is 1835 N : Node_Array renames Container.Nodes; 1836 1837 begin 1838 if Before.Container /= null then 1839 if Before.Container /= Container'Unchecked_Access then 1840 raise Program_Error with 1841 "Before cursor designates wrong container"; 1842 end if; 1843 1844 pragma Assert (Vet (Before), "bad Before cursor in Splice"); 1845 end if; 1846 1847 if Position.Node = 0 then 1848 raise Constraint_Error with "Position cursor has no element"; 1849 end if; 1850 1851 if Position.Container /= Container'Unrestricted_Access then 1852 raise Program_Error with 1853 "Position cursor designates wrong container"; 1854 end if; 1855 1856 pragma Assert (Vet (Position), "bad Position cursor in Splice"); 1857 1858 if Position.Node = Before.Node 1859 or else N (Position.Node).Next = Before.Node 1860 then 1861 return; 1862 end if; 1863 1864 pragma Assert (Container.Length >= 2); 1865 1866 if Container.Busy > 0 then 1867 raise Program_Error with 1868 "attempt to tamper with cursors (list is busy)"; 1869 end if; 1870 1871 if Before.Node = 0 then 1872 pragma Assert (Position.Node /= Container.Last); 1873 1874 if Position.Node = Container.First then 1875 Container.First := N (Position.Node).Next; 1876 N (Container.First).Prev := 0; 1877 else 1878 N (N (Position.Node).Prev).Next := N (Position.Node).Next; 1879 N (N (Position.Node).Next).Prev := N (Position.Node).Prev; 1880 end if; 1881 1882 N (Container.Last).Next := Position.Node; 1883 N (Position.Node).Prev := Container.Last; 1884 1885 Container.Last := Position.Node; 1886 N (Container.Last).Next := 0; 1887 1888 return; 1889 end if; 1890 1891 if Before.Node = Container.First then 1892 pragma Assert (Position.Node /= Container.First); 1893 1894 if Position.Node = Container.Last then 1895 Container.Last := N (Position.Node).Prev; 1896 N (Container.Last).Next := 0; 1897 else 1898 N (N (Position.Node).Prev).Next := N (Position.Node).Next; 1899 N (N (Position.Node).Next).Prev := N (Position.Node).Prev; 1900 end if; 1901 1902 N (Container.First).Prev := Position.Node; 1903 N (Position.Node).Next := Container.First; 1904 1905 Container.First := Position.Node; 1906 N (Container.First).Prev := 0; 1907 1908 return; 1909 end if; 1910 1911 if Position.Node = Container.First then 1912 Container.First := N (Position.Node).Next; 1913 N (Container.First).Prev := 0; 1914 1915 elsif Position.Node = Container.Last then 1916 Container.Last := N (Position.Node).Prev; 1917 N (Container.Last).Next := 0; 1918 1919 else 1920 N (N (Position.Node).Prev).Next := N (Position.Node).Next; 1921 N (N (Position.Node).Next).Prev := N (Position.Node).Prev; 1922 end if; 1923 1924 N (N (Before.Node).Prev).Next := Position.Node; 1925 N (Position.Node).Prev := N (Before.Node).Prev; 1926 1927 N (Before.Node).Prev := Position.Node; 1928 N (Position.Node).Next := Before.Node; 1929 1930 pragma Assert (N (Container.First).Prev = 0); 1931 pragma Assert (N (Container.Last).Next = 0); 1932 end Splice; 1933 1934 procedure Splice 1935 (Target : in out List; 1936 Before : Cursor; 1937 Source : in out List; 1938 Position : in out Cursor) 1939 is 1940 Target_Position : Cursor; 1941 1942 begin 1943 if Target'Address = Source'Address then 1944 Splice (Target, Before, Position); 1945 return; 1946 end if; 1947 1948 if Before.Container /= null then 1949 if Before.Container /= Target'Unrestricted_Access then 1950 raise Program_Error with 1951 "Before cursor designates wrong container"; 1952 end if; 1953 1954 pragma Assert (Vet (Before), "bad Before cursor in Splice"); 1955 end if; 1956 1957 if Position.Node = 0 then 1958 raise Constraint_Error with "Position cursor has no element"; 1959 end if; 1960 1961 if Position.Container /= Source'Unrestricted_Access then 1962 raise Program_Error with 1963 "Position cursor designates wrong container"; 1964 end if; 1965 1966 pragma Assert (Vet (Position), "bad Position cursor in Splice"); 1967 1968 if Target.Length >= Target.Capacity then 1969 raise Capacity_Error with "Target is full"; 1970 end if; 1971 1972 if Target.Busy > 0 then 1973 raise Program_Error with 1974 "attempt to tamper with cursors of Target (list is busy)"; 1975 end if; 1976 1977 if Source.Busy > 0 then 1978 raise Program_Error with 1979 "attempt to tamper with cursors of Source (list is busy)"; 1980 end if; 1981 1982 Insert 1983 (Container => Target, 1984 Before => Before, 1985 New_Item => Source.Nodes (Position.Node).Element, 1986 Position => Target_Position); 1987 1988 Delete (Source, Position); 1989 Position := Target_Position; 1990 end Splice; 1991 1992 ---------- 1993 -- Swap -- 1994 ---------- 1995 1996 procedure Swap 1997 (Container : in out List; 1998 I, J : Cursor) 1999 is 2000 begin 2001 if I.Node = 0 then 2002 raise Constraint_Error with "I cursor has no element"; 2003 end if; 2004 2005 if J.Node = 0 then 2006 raise Constraint_Error with "J cursor has no element"; 2007 end if; 2008 2009 if I.Container /= Container'Unchecked_Access then 2010 raise Program_Error with "I cursor designates wrong container"; 2011 end if; 2012 2013 if J.Container /= Container'Unchecked_Access then 2014 raise Program_Error with "J cursor designates wrong container"; 2015 end if; 2016 2017 if I.Node = J.Node then 2018 return; 2019 end if; 2020 2021 if Container.Lock > 0 then 2022 raise Program_Error with 2023 "attempt to tamper with elements (list is locked)"; 2024 end if; 2025 2026 pragma Assert (Vet (I), "bad I cursor in Swap"); 2027 pragma Assert (Vet (J), "bad J cursor in Swap"); 2028 2029 declare 2030 EI : Element_Type renames Container.Nodes (I.Node).Element; 2031 EJ : Element_Type renames Container.Nodes (J.Node).Element; 2032 2033 EI_Copy : constant Element_Type := EI; 2034 2035 begin 2036 EI := EJ; 2037 EJ := EI_Copy; 2038 end; 2039 end Swap; 2040 2041 ---------------- 2042 -- Swap_Links -- 2043 ---------------- 2044 2045 procedure Swap_Links 2046 (Container : in out List; 2047 I, J : Cursor) 2048 is 2049 begin 2050 if I.Node = 0 then 2051 raise Constraint_Error with "I cursor has no element"; 2052 end if; 2053 2054 if J.Node = 0 then 2055 raise Constraint_Error with "J cursor has no element"; 2056 end if; 2057 2058 if I.Container /= Container'Unrestricted_Access then 2059 raise Program_Error with "I cursor designates wrong container"; 2060 end if; 2061 2062 if J.Container /= Container'Unrestricted_Access then 2063 raise Program_Error with "J cursor designates wrong container"; 2064 end if; 2065 2066 if I.Node = J.Node then 2067 return; 2068 end if; 2069 2070 if Container.Busy > 0 then 2071 raise Program_Error with 2072 "attempt to tamper with cursors (list is busy)"; 2073 end if; 2074 2075 pragma Assert (Vet (I), "bad I cursor in Swap_Links"); 2076 pragma Assert (Vet (J), "bad J cursor in Swap_Links"); 2077 2078 declare 2079 I_Next : constant Cursor := Next (I); 2080 2081 begin 2082 if I_Next = J then 2083 Splice (Container, Before => I, Position => J); 2084 2085 else 2086 declare 2087 J_Next : constant Cursor := Next (J); 2088 2089 begin 2090 if J_Next = I then 2091 Splice (Container, Before => J, Position => I); 2092 2093 else 2094 pragma Assert (Container.Length >= 3); 2095 2096 Splice (Container, Before => I_Next, Position => J); 2097 Splice (Container, Before => J_Next, Position => I); 2098 end if; 2099 end; 2100 end if; 2101 end; 2102 end Swap_Links; 2103 2104 -------------------- 2105 -- Update_Element -- 2106 -------------------- 2107 2108 procedure Update_Element 2109 (Container : in out List; 2110 Position : Cursor; 2111 Process : not null access procedure (Element : in out Element_Type)) 2112 is 2113 begin 2114 if Position.Node = 0 then 2115 raise Constraint_Error with "Position cursor has no element"; 2116 end if; 2117 2118 if Position.Container /= Container'Unchecked_Access then 2119 raise Program_Error with 2120 "Position cursor designates wrong container"; 2121 end if; 2122 2123 pragma Assert (Vet (Position), "bad cursor in Update_Element"); 2124 2125 declare 2126 B : Natural renames Container.Busy; 2127 L : Natural renames Container.Lock; 2128 2129 begin 2130 B := B + 1; 2131 L := L + 1; 2132 2133 declare 2134 N : Node_Type renames Container.Nodes (Position.Node); 2135 begin 2136 Process (N.Element); 2137 exception 2138 when others => 2139 L := L - 1; 2140 B := B - 1; 2141 raise; 2142 end; 2143 2144 L := L - 1; 2145 B := B - 1; 2146 end; 2147 end Update_Element; 2148 2149 --------- 2150 -- Vet -- 2151 --------- 2152 2153 function Vet (Position : Cursor) return Boolean is 2154 begin 2155 if Position.Node = 0 then 2156 return Position.Container = null; 2157 end if; 2158 2159 if Position.Container = null then 2160 return False; 2161 end if; 2162 2163 declare 2164 L : List renames Position.Container.all; 2165 N : Node_Array renames L.Nodes; 2166 2167 begin 2168 if L.Length = 0 then 2169 return False; 2170 end if; 2171 2172 if L.First = 0 or L.First > L.Capacity then 2173 return False; 2174 end if; 2175 2176 if L.Last = 0 or L.Last > L.Capacity then 2177 return False; 2178 end if; 2179 2180 if N (L.First).Prev /= 0 then 2181 return False; 2182 end if; 2183 2184 if N (L.Last).Next /= 0 then 2185 return False; 2186 end if; 2187 2188 if Position.Node > L.Capacity then 2189 return False; 2190 end if; 2191 2192 -- An invariant of an active node is that its Previous and Next 2193 -- components are non-negative. Operation Free sets the Previous 2194 -- component of the node to the value -1 before actually deallocating 2195 -- the node, to mark the node as inactive. (By "dellocating" we mean 2196 -- only that the node is linked onto a list of inactive nodes used 2197 -- for storage.) This marker gives us a simple way to detect a 2198 -- dangling reference to a node. 2199 2200 if N (Position.Node).Prev < 0 then -- see Free 2201 return False; 2202 end if; 2203 2204 if N (Position.Node).Prev > L.Capacity then 2205 return False; 2206 end if; 2207 2208 if N (Position.Node).Next = Position.Node then 2209 return False; 2210 end if; 2211 2212 if N (Position.Node).Prev = Position.Node then 2213 return False; 2214 end if; 2215 2216 if N (Position.Node).Prev = 0 2217 and then Position.Node /= L.First 2218 then 2219 return False; 2220 end if; 2221 2222 pragma Assert (N (Position.Node).Prev /= 0 2223 or else Position.Node = L.First); 2224 2225 if N (Position.Node).Next = 0 2226 and then Position.Node /= L.Last 2227 then 2228 return False; 2229 end if; 2230 2231 pragma Assert (N (Position.Node).Next /= 0 2232 or else Position.Node = L.Last); 2233 2234 if L.Length = 1 then 2235 return L.First = L.Last; 2236 end if; 2237 2238 if L.First = L.Last then 2239 return False; 2240 end if; 2241 2242 if N (L.First).Next = 0 then 2243 return False; 2244 end if; 2245 2246 if N (L.Last).Prev = 0 then 2247 return False; 2248 end if; 2249 2250 if N (N (L.First).Next).Prev /= L.First then 2251 return False; 2252 end if; 2253 2254 if N (N (L.Last).Prev).Next /= L.Last then 2255 return False; 2256 end if; 2257 2258 if L.Length = 2 then 2259 if N (L.First).Next /= L.Last then 2260 return False; 2261 end if; 2262 2263 if N (L.Last).Prev /= L.First then 2264 return False; 2265 end if; 2266 2267 return True; 2268 end if; 2269 2270 if N (L.First).Next = L.Last then 2271 return False; 2272 end if; 2273 2274 if N (L.Last).Prev = L.First then 2275 return False; 2276 end if; 2277 2278 -- Eliminate earlier possibility 2279 2280 if Position.Node = L.First then 2281 return True; 2282 end if; 2283 2284 pragma Assert (N (Position.Node).Prev /= 0); 2285 2286 -- ELiminate another possibility 2287 2288 if Position.Node = L.Last then 2289 return True; 2290 end if; 2291 2292 pragma Assert (N (Position.Node).Next /= 0); 2293 2294 if N (N (Position.Node).Next).Prev /= Position.Node then 2295 return False; 2296 end if; 2297 2298 if N (N (Position.Node).Prev).Next /= Position.Node then 2299 return False; 2300 end if; 2301 2302 if L.Length = 3 then 2303 if N (L.First).Next /= Position.Node then 2304 return False; 2305 end if; 2306 2307 if N (L.Last).Prev /= Position.Node then 2308 return False; 2309 end if; 2310 end if; 2311 2312 return True; 2313 end; 2314 end Vet; 2315 2316 ----------- 2317 -- Write -- 2318 ----------- 2319 2320 procedure Write 2321 (Stream : not null access Root_Stream_Type'Class; 2322 Item : List) 2323 is 2324 Node : Count_Type; 2325 2326 begin 2327 Count_Type'Base'Write (Stream, Item.Length); 2328 2329 Node := Item.First; 2330 while Node /= 0 loop 2331 Element_Type'Write (Stream, Item.Nodes (Node).Element); 2332 Node := Item.Nodes (Node).Next; 2333 end loop; 2334 end Write; 2335 2336 procedure Write 2337 (Stream : not null access Root_Stream_Type'Class; 2338 Item : Cursor) 2339 is 2340 begin 2341 raise Program_Error with "attempt to stream list cursor"; 2342 end Write; 2343 2344 procedure Write 2345 (Stream : not null access Root_Stream_Type'Class; 2346 Item : Reference_Type) 2347 is 2348 begin 2349 raise Program_Error with "attempt to stream reference"; 2350 end Write; 2351 2352 procedure Write 2353 (Stream : not null access Root_Stream_Type'Class; 2354 Item : Constant_Reference_Type) 2355 is 2356 begin 2357 raise Program_Error with "attempt to stream reference"; 2358 end Write; 2359 2360end Ada.Containers.Bounded_Doubly_Linked_Lists; 2361