From patchwork Tue Oct 26 10:31:53 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 69218 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 10D19B70A8 for ; Tue, 26 Oct 2010 21:32:35 +1100 (EST) Received: (qmail 30722 invoked by alias); 26 Oct 2010 10:32:31 -0000 Received: (qmail 30691 invoked by uid 22791); 26 Oct 2010 10:32:19 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (194.98.77.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 26 Oct 2010 10:31:56 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id B2DACCB02EF; Tue, 26 Oct 2010 12:31:53 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id SiivAZXPAq-A; Tue, 26 Oct 2010 12:31:53 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id 9128ACB025F; Tue, 26 Oct 2010 12:31:53 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 65850D9BB4; Tue, 26 Oct 2010 12:31:53 +0200 (CEST) Date: Tue, 26 Oct 2010 12:31:53 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Matthew Heaney Subject: [Ada] New unit for bounded doubly linked list container Message-ID: <20101026103153.GA21569@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Ada 2012 added bounded versions of the container forms introduced in Ada 2005; see AI05-0001 for more information. This change incorporates the unit for the bounded doubly-linked list container, Ada.Containers.Bounded_Doubly_Linked_Lists. Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-26 Matthew Heaney * Makefile.rtl, impunit.adb: Added bounded list container. * a-cbdlli.ads, a-cbdlli.adb: New file. Index: impunit.adb =================================================================== --- impunit.adb (revision 165935) +++ impunit.adb (working copy) @@ -508,6 +508,7 @@ package body Impunit is "s-multip", -- System.Multiprocessors "s-mudido", -- System.Multiprocessors.Dispatching_Domains "a-cobove", -- Ada.Containers.Bounded_Vectors + "a-cbdlli", -- Ada.Containers.Bounded_Doubly_Linked_Lists "a-cborse", -- Ada.Containers.Bounded_Ordered_Sets "a-cborma"); -- Ada.Containers.Bounded_Ordered_Maps Index: Makefile.rtl =================================================================== --- Makefile.rtl (revision 165935) +++ Makefile.rtl (working copy) @@ -87,6 +87,7 @@ GNATRTL_NONTASKING_OBJS= \ a-calfor$(objext) \ a-catizo$(objext) \ a-cborse$(objext) \ + a-cbdlli$(objext) \ a-cborma$(objext) \ a-cdlili$(objext) \ a-cgaaso$(objext) \ Index: a-cbdlli.adb =================================================================== --- a-cbdlli.adb (revision 0) +++ a-cbdlli.adb (revision 0) @@ -0,0 +1,2005 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; Index: a-cbdlli.ads =================================================================== --- a-cbdlli.ads (revision 0) +++ a-cbdlli.ads (revision 0) @@ -0,0 +1,270 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_DOUBLY_LINKED_LISTS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +private with Ada.Streams; + +generic + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) + return Boolean is <>; + +package Ada.Containers.Bounded_Doubly_Linked_Lists is + pragma Pure; + pragma Remote_Types; + + type List (Capacity : Count_Type) is tagged private; + pragma Preelaborable_Initialization (List); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_List : constant List; + + No_Element : constant Cursor; + + function "=" (Left, Right : List) return Boolean; + + function Length (Container : List) return Count_Type; + + function Is_Empty (Container : List) return Boolean; + + procedure Clear (Container : in out List); + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : in out List; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Assign (Target : in out List; Source : List); + + function Copy (Source : List; Capacity : Count_Type := 0) return List; + + procedure Move + (Target : in out List; + Source : in out List); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Insert + (Container : in out List; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1); + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1); + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1); + + procedure Reverse_Elements (Container : in out List); + + procedure Swap + (Container : in out List; + I, J : Cursor); + + procedure Swap_Links + (Container : in out List; + I, J : Cursor); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : in out Cursor); + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor); + + function First (Container : List) return Cursor; + + function First_Element (Container : List) return Element_Type; + + function Last (Container : List) return Cursor; + + function Last_Element (Container : List) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Contains + (Container : List; + Item : Element_Type) return Boolean; + + function Has_Element (Position : Cursor) return Boolean; + + procedure Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)); + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is + + function Is_Sorted (Container : List) return Boolean; + + procedure Sort (Container : in out List); + + procedure Merge (Target, Source : in out List); + + end Generic_Sorting; + +private + + pragma Inline (Next); + pragma Inline (Previous); + + type Node_Type is record + Prev : Count_Type'Base; + Next : Count_Type; + Element : Element_Type; + end record; + + type Node_Array is array (Count_Type range <>) of Node_Type; + + type List (Capacity : Count_Type) is tagged record + Nodes : Node_Array (1 .. Capacity) := (others => <>); + Free : Count_Type'Base := -1; + First : Count_Type := 0; + Last : Count_Type := 0; + Length : Count_Type := 0; + Busy : Natural := 0; + Lock : Natural := 0; + end record; + + use Ada.Streams; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out List); + + for List'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : List); + + for List'Write use Write; + + type List_Access is access all List; + for List_Access'Storage_Size use 0; + + type Cursor is + record + Container : List_Access; + Node : Count_Type := 0; + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + Empty_List : constant List := (Capacity => 0, others => <>); + + No_Element : constant Cursor := Cursor'(null, 0); + +end Ada.Containers.Bounded_Doubly_Linked_Lists;