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