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