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