------------------------------------------------------------------------------ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- -- ADA.CONTAINERS.BOUNDED_DOUBLY_LINKED_LISTS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ with System; use type System.Address; package body Ada.Containers.Bounded_Doubly_Linked_Lists is ----------------------- -- Local Subprograms -- ----------------------- procedure Allocate (Container : in out List; New_Item : Element_Type; New_Node : out Count_Type); procedure Allocate (Container : in out List; New_Node : out Count_Type); procedure Allocate (Container : in out List; Stream : not null access Root_Stream_Type'Class; New_Node : out Count_Type); procedure Free (Container : in out List; X : Count_Type); procedure Insert_Internal (Container : in out List; Before : Count_Type; New_Node : Count_Type); function Vet (Position : Cursor) return Boolean; --------- -- "=" -- --------- function "=" (Left, Right : List) return Boolean is LN : Node_Array renames Left.Nodes; RN : Node_Array renames Right.Nodes; LI, RI : Count_Type; begin if Left'Address = Right'Address then return True; end if; if Left.Length /= Right.Length then return False; end if; LI := Left.First; RI := Right.First; for J in 1 .. Left.Length loop if LN (LI).Element /= RN (RI).Element then return False; end if; LI := LN (LI).Next; RI := RN (RI).Next; end loop; return True; end "="; -------------- -- Allocate -- -------------- procedure Allocate (Container : in out List; New_Item : Element_Type; New_Node : out Count_Type) is N : Node_Array renames Container.Nodes; begin if Container.Free >= 0 then New_Node := Container.Free; -- We always perform the assignment first, before we -- change container state, in order to defend against -- exceptions duration assignment. N (New_Node).Element := New_Item; Container.Free := N (New_Node).Next; else -- A negative free store value means that the links of the nodes -- in the free store have not been initialized. In this case, the -- nodes are physically contiguous in the array, starting at the -- index that is the absolute value of the Container.Free, and -- continuing until the end of the array (Nodes'Last). New_Node := abs Container.Free; -- As above, we perform this assignment first, before modifying -- any container state. N (New_Node).Element := New_Item; Container.Free := Container.Free - 1; end if; end Allocate; procedure Allocate (Container : in out List; Stream : not null access Root_Stream_Type'Class; New_Node : out Count_Type) is N : Node_Array renames Container.Nodes; begin if Container.Free >= 0 then New_Node := Container.Free; -- We always perform the assignment first, before we -- change container state, in order to defend against -- exceptions duration assignment. Element_Type'Read (Stream, N (New_Node).Element); Container.Free := N (New_Node).Next; else -- A negative free store value means that the links of the nodes -- in the free store have not been initialized. In this case, the -- nodes are physically contiguous in the array, starting at the -- index that is the absolute value of the Container.Free, and -- continuing until the end of the array (Nodes'Last). New_Node := abs Container.Free; -- As above, we perform this assignment first, before modifying -- any container state. Element_Type'Read (Stream, N (New_Node).Element); Container.Free := Container.Free - 1; end if; end Allocate; procedure Allocate (Container : in out List; New_Node : out Count_Type) is N : Node_Array renames Container.Nodes; begin if Container.Free >= 0 then New_Node := Container.Free; Container.Free := N (New_Node).Next; else -- As explained above, a negative free store value means that the -- links for the nodes in the free store have not been initialized. New_Node := abs Container.Free; Container.Free := Container.Free - 1; end if; end Allocate; ------------ -- Append -- ------------ procedure Append (Container : in out List; New_Item : Element_Type; Count : Count_Type := 1) is begin Insert (Container, No_Element, New_Item, Count); end Append; ------------ -- Assign -- ------------ procedure Assign (Target : in out List; Source : List) is SN : Node_Array renames Source.Nodes; J : Count_Type; begin if Target'Address = Source'Address then return; end if; if Target.Capacity < Source.Length then raise Capacity_Error -- ??? with "Target capacity is less than Source length"; end if; Target.Clear; J := Source.First; while J /= 0 loop Target.Append (SN (J).Element); J := SN (J).Next; end loop; end Assign; ----------- -- Clear -- ----------- procedure Clear (Container : in out List) is N : Node_Array renames Container.Nodes; X : Count_Type; begin if Container.Length = 0 then pragma Assert (Container.First = 0); pragma Assert (Container.Last = 0); pragma Assert (Container.Busy = 0); pragma Assert (Container.Lock = 0); return; end if; pragma Assert (Container.First >= 1); pragma Assert (Container.Last >= 1); pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (list is busy)"; end if; while Container.Length > 1 loop X := Container.First; pragma Assert (N (N (X).Next).Prev = Container.First); Container.First := N (X).Next; N (Container.First).Prev := 0; Container.Length := Container.Length - 1; Free (Container, X); end loop; X := Container.First; pragma Assert (X = Container.Last); Container.First := 0; Container.Last := 0; Container.Length := 0; Free (Container, X); end Clear; -------------- -- Contains -- -------------- function Contains (Container : List; Item : Element_Type) return Boolean is begin return Find (Container, Item) /= No_Element; end Contains; ---------- -- Copy -- ---------- function Copy (Source : List; Capacity : Count_Type := 0) return List is C : Count_Type; begin if Capacity = 0 then C := Source.Length; elsif Capacity >= Source.Length then C := Capacity; else raise Capacity_Error with "Capacity value too small"; end if; return Target : List (Capacity => C) do Assign (Target => Target, Source => Source); end return; end Copy; ------------ -- Delete -- ------------ procedure Delete (Container : in out List; Position : in out Cursor; Count : Count_Type := 1) is N : Node_Array renames Container.Nodes; X : Count_Type; begin if Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; if Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad cursor in Delete"); pragma Assert (Container.First >= 1); pragma Assert (Container.Last >= 1); pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); if Position.Node = Container.First then Delete_First (Container, Count); Position := No_Element; return; end if; if Count = 0 then Position := No_Element; return; end if; if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (list is busy)"; end if; for Index in 1 .. Count loop pragma Assert (Container.Length >= 2); X := Position.Node; Container.Length := Container.Length - 1; if X = Container.Last then Position := No_Element; Container.Last := N (X).Prev; N (Container.Last).Next := 0; Free (Container, X); return; end if; Position.Node := N (X).Next; N (N (X).Next).Prev := N (X).Prev; N (N (X).Prev).Next := N (X).Next; Free (Container, X); end loop; Position := No_Element; end Delete; ------------------ -- Delete_First -- ------------------ procedure Delete_First (Container : in out List; Count : Count_Type := 1) is N : Node_Array renames Container.Nodes; X : Count_Type; begin if Count >= Container.Length then Clear (Container); return; end if; if Count = 0 then return; end if; if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (list is busy)"; end if; for I in 1 .. Count loop X := Container.First; pragma Assert (N (N (X).Next).Prev = Container.First); Container.First := N (X).Next; N (Container.First).Prev := 0; Container.Length := Container.Length - 1; Free (Container, X); end loop; end Delete_First; ----------------- -- Delete_Last -- ----------------- procedure Delete_Last (Container : in out List; Count : Count_Type := 1) is N : Node_Array renames Container.Nodes; X : Count_Type; begin if Count >= Container.Length then Clear (Container); return; end if; if Count = 0 then return; end if; if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (list is busy)"; end if; for I in 1 .. Count loop X := Container.Last; pragma Assert (N (N (X).Prev).Next = Container.Last); Container.Last := N (X).Prev; N (Container.Last).Next := 0; Container.Length := Container.Length - 1; Free (Container, X); end loop; end Delete_Last; ------------- -- Element -- ------------- function Element (Position : Cursor) return Element_Type is begin if Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; pragma Assert (Vet (Position), "bad cursor in Element"); return Position.Container.Nodes (Position.Node).Element; end Element; ---------- -- Find -- ---------- function Find (Container : List; Item : Element_Type; Position : Cursor := No_Element) return Cursor is Nodes : Node_Array renames Container.Nodes; Node : Count_Type := Position.Node; begin if Node = 0 then Node := Container.First; else if Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad cursor in Find"); end if; while Node /= 0 loop if Nodes (Node).Element = Item then return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Nodes (Node).Next; end loop; return No_Element; end Find; ----------- -- First -- ----------- function First (Container : List) return Cursor is begin if Container.First = 0 then return No_Element; end if; return Cursor'(Container'Unrestricted_Access, Container.First); end First; ------------------- -- First_Element -- ------------------- function First_Element (Container : List) return Element_Type is begin if Container.First = 0 then raise Constraint_Error with "list is empty"; end if; return Container.Nodes (Container.First).Element; end First_Element; ---------- -- Free -- ---------- procedure Free (Container : in out List; X : Count_Type) is pragma Assert (X > 0); pragma Assert (X <= Container.Capacity); N : Node_Array renames Container.Nodes; pragma Assert (N (X).Prev >= 0); -- node is active begin -- The list container actually contains two lists: one for the "active" -- nodes that contain elements that have been inserted onto the list, -- and another for the "inactive" nodes for the free store. -- -- We desire that merely declaring an object should have only minimal -- cost; specially, we want to avoid having to initialize the free -- store (to fill in the links), especially if the capacity is large. -- -- The head of the free list is indicated by Container.Free. If its -- value is non-negative, then the free store has been initialized -- in the "normal" way: Container.Free points to the head of the list -- of free (inactive) nodes, and the value 0 means the free list is -- empty. Each node on the free list has been initialized to point -- to the next free node (via its Next component), and the value 0 -- means that this is the last free node. -- -- If Container.Free is negative, then the links on the free store -- have not been initialized. In this case the link values are -- implied: the free store comprises the components of the node array -- started with the absolute value of Container.Free, and continuing -- until the end of the array (Nodes'Last). -- -- If the list container is manipulated on one end only (for example -- if the container were being used as a stack), then there is no -- need to initialize the free store, since the inactive nodes are -- physically contiguous (in fact, they lie immediately beyond the -- logical end being manipulated). The only time we need to actually -- initialize the nodes in the free store is if the node that becomes -- inactive is not at the end of the list. The free store would then -- be discontigous and so its nodes would need to be linked in the -- traditional way. -- -- ??? -- It might be possible to perform an optimization here. Suppose that -- the free store can be represented as having two parts: one -- comprising the non-contiguous inactive nodes linked together -- in the normal way, and the other comprising the contiguous -- inactive nodes (that are not linked together, at the end of the -- nodes array). This would allow us to never have to initialize -- the free store, except in a lazy way as nodes become inactive. -- When an element is deleted from the list container, its node -- becomes inactive, and so we set its Prev component to a negative -- value, to indicate that it is now inactive. This provides a useful -- way to detect a dangling cursor reference. N (X).Prev := -1; -- Node is deallocated (not on active list) if Container.Free >= 0 then -- The free store has previously been initialized. All we need to -- do here is link the newly-free'd node onto the free list. N (X).Next := Container.Free; Container.Free := X; elsif X + 1 = abs Container.Free then -- The free store has not been initialized, and the node becoming -- inactive immediately precedes the start of the free store. All -- we need to do is move the start of the free store back by one. N (X).Next := 0; -- Not strictly necessary, but marginally safer Container.Free := Container.Free + 1; else -- The free store has not been initialized, and the node becoming -- inactive does not immediately precede the free store. Here we -- first initialize the free store (meaning the links are given -- values in the traditional way), and then link the newly-free'd -- node onto the head of the free store. -- ??? -- See the comments above for an optimization opportunity. If -- the next link for a node on the free store is negative, then -- this means the remaining nodes on the free store are -- physically contiguous, starting as the absolute value of -- that index value. Container.Free := abs Container.Free; if Container.Free > Container.Capacity then Container.Free := 0; else for I in Container.Free .. Container.Capacity - 1 loop N (I).Next := I + 1; end loop; N (Container.Capacity).Next := 0; end if; N (X).Next := Container.Free; Container.Free := X; end if; end Free; --------------------- -- Generic_Sorting -- --------------------- package body Generic_Sorting is --------------- -- Is_Sorted -- --------------- function Is_Sorted (Container : List) return Boolean is Nodes : Node_Array renames Container.Nodes; Node : Count_Type := Container.First; begin for I in 2 .. Container.Length loop if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then return False; end if; Node := Nodes (Node).Next; end loop; return True; end Is_Sorted; ----------- -- Merge -- ----------- procedure Merge (Target : in out List; Source : in out List) is LN : Node_Array renames Target.Nodes; RN : Node_Array renames Source.Nodes; LI, RI : Cursor; begin if Target'Address = Source'Address then return; end if; if Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Target (list is busy)"; end if; if Source.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Source (list is busy)"; end if; LI := First (Target); RI := First (Source); while RI.Node /= 0 loop pragma Assert (RN (RI.Node).Next = 0 or else not (RN (RN (RI.Node).Next).Element < RN (RI.Node).Element)); if LI.Node = 0 then Splice (Target, No_Element, Source); return; end if; pragma Assert (LN (LI.Node).Next = 0 or else not (LN (LN (LI.Node).Next).Element < LN (LI.Node).Element)); if RN (RI.Node).Element < LN (LI.Node).Element then declare RJ : Cursor := RI; pragma Warnings (Off, RJ); begin RI.Node := RN (RI.Node).Next; Splice (Target, LI, Source, RJ); end; else LI.Node := LN (LI.Node).Next; end if; end loop; end Merge; ---------- -- Sort -- ---------- procedure Sort (Container : in out List) is N : Node_Array renames Container.Nodes; procedure Partition (Pivot, Back : Count_Type); procedure Sort (Front, Back : Count_Type); --------------- -- Partition -- --------------- procedure Partition (Pivot, Back : Count_Type) is Node : Count_Type := N (Pivot).Next; begin while Node /= Back loop if N (Node).Element < N (Pivot).Element then declare Prev : constant Count_Type := N (Node).Prev; Next : constant Count_Type := N (Node).Next; begin N (Prev).Next := Next; if Next = 0 then Container.Last := Prev; else N (Next).Prev := Prev; end if; N (Node).Next := Pivot; N (Node).Prev := N (Pivot).Prev; N (Pivot).Prev := Node; if N (Node).Prev = 0 then Container.First := Node; else N (N (Node).Prev).Next := Node; end if; Node := Next; end; else Node := N (Node).Next; end if; end loop; end Partition; ---------- -- Sort -- ---------- procedure Sort (Front, Back : Count_Type) is Pivot : constant Count_Type := (if Front = 0 then Container.First else N (Front).Next); begin if Pivot /= Back then Partition (Pivot, Back); Sort (Front, Pivot); Sort (Pivot, Back); end if; end Sort; -- Start of processing for Sort begin if Container.Length <= 1 then return; end if; pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (list is busy)"; end if; Sort (Front => 0, Back => 0); pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); end Sort; end Generic_Sorting; ----------------- -- Has_Element -- ----------------- function Has_Element (Position : Cursor) return Boolean is begin pragma Assert (Vet (Position), "bad cursor in Has_Element"); return Position.Node /= 0; end Has_Element; ------------ -- Insert -- ------------ procedure Insert (Container : in out List; Before : Cursor; New_Item : Element_Type; Position : out Cursor; Count : Count_Type := 1) is New_Node : Count_Type; begin if Before.Container /= null then if Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong list"; end if; pragma Assert (Vet (Before), "bad cursor in Insert"); end if; if Count = 0 then Position := Before; return; end if; if Container.Length > Container.Capacity - Count then raise Constraint_Error with "new length exceeds capacity"; end if; if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (list is busy)"; end if; Allocate (Container, New_Item, New_Node); Insert_Internal (Container, Before.Node, New_Node => New_Node); Position := Cursor'(Container'Unchecked_Access, Node => New_Node); for Index in Count_Type'(2) .. Count loop Allocate (Container, New_Item, New_Node => New_Node); Insert_Internal (Container, Before.Node, New_Node => New_Node); end loop; end Insert; procedure Insert (Container : in out List; Before : Cursor; New_Item : Element_Type; Count : Count_Type := 1) is Position : Cursor; pragma Unreferenced (Position); begin Insert (Container, Before, New_Item, Position, Count); end Insert; procedure Insert (Container : in out List; Before : Cursor; Position : out Cursor; Count : Count_Type := 1) is New_Node : Count_Type; begin if Before.Container /= null then if Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong list"; end if; pragma Assert (Vet (Before), "bad cursor in Insert"); end if; if Count = 0 then Position := Before; return; end if; if Container.Length > Container.Capacity - Count then raise Constraint_Error with "new length exceeds capacity"; end if; if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (list is busy)"; end if; Allocate (Container, New_Node => New_Node); Insert_Internal (Container, Before.Node, New_Node); Position := Cursor'(Container'Unchecked_Access, New_Node); for Index in Count_Type'(2) .. Count loop Allocate (Container, New_Node => New_Node); Insert_Internal (Container, Before.Node, New_Node); end loop; end Insert; --------------------- -- Insert_Internal -- --------------------- procedure Insert_Internal (Container : in out List; Before : Count_Type; New_Node : Count_Type) is N : Node_Array renames Container.Nodes; begin if Container.Length = 0 then pragma Assert (Before = 0); pragma Assert (Container.First = 0); pragma Assert (Container.Last = 0); Container.First := New_Node; N (Container.First).Prev := 0; Container.Last := New_Node; N (Container.Last).Next := 0; elsif Before = 0 then -- means append pragma Assert (N (Container.Last).Next = 0); N (Container.Last).Next := New_Node; N (New_Node).Prev := Container.Last; Container.Last := New_Node; N (Container.Last).Next := 0; elsif Before = Container.First then -- means prepend pragma Assert (N (Container.First).Prev = 0); N (Container.First).Prev := New_Node; N (New_Node).Next := Container.First; Container.First := New_Node; N (Container.First).Prev := 0; else pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); N (New_Node).Next := Before; N (New_Node).Prev := N (Before).Prev; N (N (Before).Prev).Next := New_Node; N (Before).Prev := New_Node; end if; Container.Length := Container.Length + 1; end Insert_Internal; -------------- -- Is_Empty -- -------------- function Is_Empty (Container : List) return Boolean is begin return Container.Length = 0; end Is_Empty; ------------- -- Iterate -- ------------- procedure Iterate (Container : List; Process : not null access procedure (Position : Cursor)) is C : List renames Container'Unrestricted_Access.all; B : Natural renames C.Busy; Node : Count_Type := Container.First; begin B := B + 1; begin while Node /= 0 loop Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Container.Nodes (Node).Next; end loop; exception when others => B := B - 1; raise; end; B := B - 1; end Iterate; ---------- -- Last -- ---------- function Last (Container : List) return Cursor is begin if Container.Last = 0 then return No_Element; end if; return Cursor'(Container'Unrestricted_Access, Container.Last); end Last; ------------------ -- Last_Element -- ------------------ function Last_Element (Container : List) return Element_Type is begin if Container.Last = 0 then raise Constraint_Error with "list is empty"; end if; return Container.Nodes (Container.Last).Element; end Last_Element; ------------ -- Length -- ------------ function Length (Container : List) return Count_Type is begin return Container.Length; end Length; ---------- -- Move -- ---------- procedure Move (Target : in out List; Source : in out List) is N : Node_Array renames Source.Nodes; X : Count_Type; begin if Target'Address = Source'Address then return; end if; if Target.Capacity < Source.Length then raise Capacity_Error with "Source length exceeds Target capacity"; end if; if Source.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Source (list is busy)"; end if; Clear (Target); while Source.Length > 0 loop X := Source.First; Append (Target, N (X).Element); Source.First := N (X).Next; N (Source.First).Prev := 0; Source.Length := Source.Length - 1; Free (Source, X); end loop; end Move; ---------- -- Next -- ---------- procedure Next (Position : in out Cursor) is begin Position := Next (Position); end Next; function Next (Position : Cursor) return Cursor is begin if Position.Node = 0 then return No_Element; end if; pragma Assert (Vet (Position), "bad cursor in Next"); declare Nodes : Node_Array renames Position.Container.Nodes; Node : constant Count_Type := Nodes (Position.Node).Next; begin if Node = 0 then return No_Element; end if; return Cursor'(Position.Container, Node); end; end Next; ------------- -- Prepend -- ------------- procedure Prepend (Container : in out List; New_Item : Element_Type; Count : Count_Type := 1) is begin Insert (Container, First (Container), New_Item, Count); end Prepend; -------------- -- Previous -- -------------- procedure Previous (Position : in out Cursor) is begin Position := Previous (Position); end Previous; function Previous (Position : Cursor) return Cursor is begin if Position.Node = 0 then return No_Element; end if; pragma Assert (Vet (Position), "bad cursor in Previous"); declare Nodes : Node_Array renames Position.Container.Nodes; Node : constant Count_Type := Nodes (Position.Node).Prev; begin if Node = 0 then return No_Element; end if; return Cursor'(Position.Container, Node); end; end Previous; ------------------- -- Query_Element -- ------------------- procedure Query_Element (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is begin if Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; pragma Assert (Vet (Position), "bad cursor in Query_Element"); declare C : List renames Position.Container.all'Unrestricted_Access.all; B : Natural renames C.Busy; L : Natural renames C.Lock; begin B := B + 1; L := L + 1; declare N : Node_Type renames C.Nodes (Position.Node); begin Process (N.Element); exception when others => L := L - 1; B := B - 1; raise; end; L := L - 1; B := B - 1; end; end Query_Element; ---------- -- Read -- ---------- procedure Read (Stream : not null access Root_Stream_Type'Class; Item : out List) is N : Count_Type'Base; X : Count_Type; begin Clear (Item); Count_Type'Base'Read (Stream, N); if N < 0 then raise Program_Error with "bad list length (corrupt stream)"; end if; if N = 0 then return; end if; if N > Item.Capacity then raise Constraint_Error with "length exceeds capacity"; end if; for Idx in 1 .. N loop Allocate (Item, Stream, New_Node => X); Insert_Internal (Item, Before => 0, New_Node => X); end loop; end Read; procedure Read (Stream : not null access Root_Stream_Type'Class; Item : out Cursor) is begin raise Program_Error with "attempt to stream list cursor"; end Read; --------------------- -- Replace_Element -- --------------------- procedure Replace_Element (Container : in out List; Position : Cursor; New_Item : Element_Type) is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; if Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; end if; if Container.Lock > 0 then raise Program_Error with "attempt to tamper with elements (list is locked)"; end if; pragma Assert (Vet (Position), "bad cursor in Replace_Element"); Container.Nodes (Position.Node).Element := New_Item; end Replace_Element; ---------------------- -- Reverse_Elements -- ---------------------- procedure Reverse_Elements (Container : in out List) is N : Node_Array renames Container.Nodes; I : Count_Type := Container.First; J : Count_Type := Container.Last; procedure Swap (L, R : Count_Type); ---------- -- Swap -- ---------- procedure Swap (L, R : Count_Type) is LN : constant Count_Type := N (L).Next; LP : constant Count_Type := N (L).Prev; RN : constant Count_Type := N (R).Next; RP : constant Count_Type := N (R).Prev; begin if LP /= 0 then N (LP).Next := R; end if; if RN /= 0 then N (RN).Prev := L; end if; N (L).Next := RN; N (R).Prev := LP; if LN = R then pragma Assert (RP = L); N (L).Prev := R; N (R).Next := L; else N (L).Prev := RP; N (RP).Next := L; N (R).Next := LN; N (LN).Prev := R; end if; end Swap; -- Start of processing for Reverse_Elements begin if Container.Length <= 1 then return; end if; pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (list is busy)"; end if; Container.First := J; Container.Last := I; loop Swap (L => I, R => J); J := N (J).Next; exit when I = J; I := N (I).Prev; exit when I = J; Swap (L => J, R => I); I := N (I).Next; exit when I = J; J := N (J).Prev; exit when I = J; end loop; pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); end Reverse_Elements; ------------------ -- Reverse_Find -- ------------------ function Reverse_Find (Container : List; Item : Element_Type; Position : Cursor := No_Element) return Cursor is Node : Count_Type := Position.Node; begin if Node = 0 then Node := Container.Last; else if Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); end if; while Node /= 0 loop if Container.Nodes (Node).Element = Item then return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Container.Nodes (Node).Prev; end loop; return No_Element; end Reverse_Find; --------------------- -- Reverse_Iterate -- --------------------- procedure Reverse_Iterate (Container : List; Process : not null access procedure (Position : Cursor)) is C : List renames Container'Unrestricted_Access.all; B : Natural renames C.Busy; Node : Count_Type := Container.Last; begin B := B + 1; begin while Node /= 0 loop Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Container.Nodes (Node).Prev; end loop; exception when others => B := B - 1; raise; end; B := B - 1; end Reverse_Iterate; ------------ -- Splice -- ------------ procedure Splice (Target : in out List; Before : Cursor; Source : in out List) is begin if Before.Container /= null then if Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; end if; pragma Assert (Vet (Before), "bad cursor in Splice"); end if; if Target'Address = Source'Address or else Source.Length = 0 then return; end if; pragma Assert (Source.Nodes (Source.First).Prev = 0); pragma Assert (Source.Nodes (Source.Last).Next = 0); if Target.Length > Count_Type'Last - Source.Length then raise Constraint_Error with "new length exceeds maximum"; end if; if Target.Length + Source.Length > Target.Capacity then raise Capacity_Error with "new length exceeds target capacity"; end if; if Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Target (list is busy)"; end if; if Source.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Source (list is busy)"; end if; loop Insert (Target, Before, Source.Nodes (Source.Last).Element); Delete_Last (Source); exit when Is_Empty (Source); end loop; end Splice; procedure Splice (Container : in out List; Before : Cursor; Position : Cursor) is N : Node_Array renames Container.Nodes; begin if Before.Container /= null then if Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor designates wrong container"; end if; pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; if Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; if Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad Position cursor in Splice"); if Position.Node = Before.Node or else N (Position.Node).Next = Before.Node then return; end if; pragma Assert (Container.Length >= 2); if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (list is busy)"; end if; if Before.Node = 0 then pragma Assert (Position.Node /= Container.Last); if Position.Node = Container.First then Container.First := N (Position.Node).Next; N (Container.First).Prev := 0; else N (N (Position.Node).Prev).Next := N (Position.Node).Next; N (N (Position.Node).Next).Prev := N (Position.Node).Prev; end if; N (Container.Last).Next := Position.Node; N (Position.Node).Prev := Container.Last; Container.Last := Position.Node; N (Container.Last).Next := 0; return; end if; if Before.Node = Container.First then pragma Assert (Position.Node /= Container.First); if Position.Node = Container.Last then Container.Last := N (Position.Node).Prev; N (Container.Last).Next := 0; else N (N (Position.Node).Prev).Next := N (Position.Node).Next; N (N (Position.Node).Next).Prev := N (Position.Node).Prev; end if; N (Container.First).Prev := Position.Node; N (Position.Node).Next := Container.First; Container.First := Position.Node; N (Container.First).Prev := 0; return; end if; if Position.Node = Container.First then Container.First := N (Position.Node).Next; N (Container.First).Prev := 0; elsif Position.Node = Container.Last then Container.Last := N (Position.Node).Prev; N (Container.Last).Next := 0; else N (N (Position.Node).Prev).Next := N (Position.Node).Next; N (N (Position.Node).Next).Prev := N (Position.Node).Prev; end if; N (N (Before.Node).Prev).Next := Position.Node; N (Position.Node).Prev := N (Before.Node).Prev; N (Before.Node).Prev := Position.Node; N (Position.Node).Next := Before.Node; pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); end Splice; procedure Splice (Target : in out List; Before : Cursor; Source : in out List; Position : in out Cursor) is Target_Position : Cursor; begin if Target'Address = Source'Address then Splice (Target, Before, Position); return; end if; if Before.Container /= null then if Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; end if; pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; if Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; if Position.Container /= Source'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad Position cursor in Splice"); if Target.Length >= Target.Capacity then raise Capacity_Error with "Target is full"; end if; if Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Target (list is busy)"; end if; if Source.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Source (list is busy)"; end if; Insert (Container => Target, Before => Before, New_Item => Source.Nodes (Position.Node).Element, Position => Target_Position); Delete (Source, Position); Position := Target_Position; end Splice; ---------- -- Swap -- ---------- procedure Swap (Container : in out List; I, J : Cursor) is begin if I.Node = 0 then raise Constraint_Error with "I cursor has no element"; end if; if J.Node = 0 then raise Constraint_Error with "J cursor has no element"; end if; if I.Container /= Container'Unchecked_Access then raise Program_Error with "I cursor designates wrong container"; end if; if J.Container /= Container'Unchecked_Access then raise Program_Error with "J cursor designates wrong container"; end if; if I.Node = J.Node then return; end if; if Container.Lock > 0 then raise Program_Error with "attempt to tamper with elements (list is locked)"; end if; pragma Assert (Vet (I), "bad I cursor in Swap"); pragma Assert (Vet (J), "bad J cursor in Swap"); declare EI : Element_Type renames Container.Nodes (I.Node).Element; EJ : Element_Type renames Container.Nodes (J.Node).Element; EI_Copy : constant Element_Type := EI; begin EI := EJ; EJ := EI_Copy; end; end Swap; ---------------- -- Swap_Links -- ---------------- procedure Swap_Links (Container : in out List; I, J : Cursor) is begin if I.Node = 0 then raise Constraint_Error with "I cursor has no element"; end if; if J.Node = 0 then raise Constraint_Error with "J cursor has no element"; end if; if I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor designates wrong container"; end if; if J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor designates wrong container"; end if; if I.Node = J.Node then return; end if; if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (list is busy)"; end if; pragma Assert (Vet (I), "bad I cursor in Swap_Links"); pragma Assert (Vet (J), "bad J cursor in Swap_Links"); declare I_Next : constant Cursor := Next (I); begin if I_Next = J then Splice (Container, Before => I, Position => J); else declare J_Next : constant Cursor := Next (J); begin if J_Next = I then Splice (Container, Before => J, Position => I); else pragma Assert (Container.Length >= 3); Splice (Container, Before => I_Next, Position => J); Splice (Container, Before => J_Next, Position => I); end if; end; end if; end; end Swap_Links; -------------------- -- Update_Element -- -------------------- procedure Update_Element (Container : in out List; Position : Cursor; Process : not null access procedure (Element : in out Element_Type)) is begin if Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; if Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad cursor in Update_Element"); declare B : Natural renames Container.Busy; L : Natural renames Container.Lock; begin B := B + 1; L := L + 1; declare N : Node_Type renames Container.Nodes (Position.Node); begin Process (N.Element); exception when others => L := L - 1; B := B - 1; raise; end; L := L - 1; B := B - 1; end; end Update_Element; --------- -- Vet -- --------- function Vet (Position : Cursor) return Boolean is begin if Position.Node = 0 then return Position.Container = null; end if; if Position.Container = null then return False; end if; declare L : List renames Position.Container.all; N : Node_Array renames L.Nodes; begin if L.Length = 0 then return False; end if; if L.First = 0 or L.First > L.Capacity then return False; end if; if L.Last = 0 or L.Last > L.Capacity then return False; end if; if N (L.First).Prev /= 0 then return False; end if; if N (L.Last).Next /= 0 then return False; end if; if Position.Node > L.Capacity then return False; end if; if N (Position.Node).Prev < 0 then -- see Free return False; end if; if N (Position.Node).Prev > L.Capacity then return False; end if; if N (Position.Node).Next = Position.Node then return False; end if; if N (Position.Node).Prev = Position.Node then return False; end if; if N (Position.Node).Prev = 0 and then Position.Node /= L.First then return False; end if; -- If we get here, we know that this disjunction is true: -- N (Position.Node).Prev /= 0 or else Position.Node = L.First if N (Position.Node).Next = 0 and then Position.Node /= L.Last then return False; end if; -- If we get here, we know that this disjunction is true: -- N (Position.Node).Next /= 0 or else Position.Node = L.Last if L.Length = 1 then return L.First = L.Last; end if; if L.First = L.Last then return False; end if; if N (L.First).Next = 0 then return False; end if; if N (L.Last).Prev = 0 then return False; end if; if N (N (L.First).Next).Prev /= L.First then return False; end if; if N (N (L.Last).Prev).Next /= L.Last then return False; end if; if L.Length = 2 then if N (L.First).Next /= L.Last then return False; end if; if N (L.Last).Prev /= L.First then return False; end if; return True; end if; if N (L.First).Next = L.Last then return False; end if; if N (L.Last).Prev = L.First then return False; end if; if Position.Node = L.First then -- eliminates ealier disjunct return True; end if; -- If we get here, we know, per disjunctive syllogism (modus -- tollendo ponens), that this predicate is true: -- N (Position.Node).Prev /= 0 if Position.Node = L.Last then -- eliminates earlier disjunct return True; end if; -- If we get here, we know, per disjunctive syllogism (modus -- tollendo ponens), that this predicate is true: -- N (Position.Node).Next /= 0 if N (N (Position.Node).Next).Prev /= Position.Node then return False; end if; if N (N (Position.Node).Prev).Next /= Position.Node then return False; end if; if L.Length = 3 then if N (L.First).Next /= Position.Node then return False; end if; if N (L.Last).Prev /= Position.Node then return False; end if; end if; return True; end; end Vet; ----------- -- Write -- ----------- procedure Write (Stream : not null access Root_Stream_Type'Class; Item : List) is Node : Count_Type; begin Count_Type'Base'Write (Stream, Item.Length); Node := Item.First; while Node /= 0 loop Element_Type'Write (Stream, Item.Nodes (Node).Element); Node := Item.Nodes (Node).Next; end loop; end Write; procedure Write (Stream : not null access Root_Stream_Type'Class; Item : Cursor) is begin raise Program_Error with "attempt to stream list cursor"; end Write; end Ada.Containers.Bounded_Doubly_Linked_Lists;