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