Re: List Container Strawman 1.4

["Matthew Heaney" <mheaney@on2.com>]

"Matthew Heaney" <mheaney@on2.com> wrote in message
news:u2pitjhps1bp07@corp.supernews.com...
> If you wanted, you could generalize this further (as the STL does) to
> abstract away the target type (in the example above we've hard-coded an
> array type as the target type).  To do this for arrays you'd need an
> appropriate iterator type; maybe Interfaces.C.Pointers would work.

In the example below I wrote an array iterator and a Generic_Copy algorithm
that works for any target type.  The basic idea is:

declare
   ...
    procedure Copy is
         new Generic_Copy
           (Integer_Lists.Iterator_Type,
            Integer_Arrays.Iterator_Type);

      Items : aliased Integer_Array (1 .. Length (List));
      Iter : Integer_Arrays.Iterator_Type := Items
(Items'First)'Unchecked_Access;
   begin
      Copy (First (List), Back (List), Iter);
  end;

This is exactly how the STL does things.

The code below is suitable for use with gnatchop.

--STX
with System.Storage_Elements;
with Ada.Unchecked_Conversion;

package body Array_Iterators is

   use type System.Storage_Elements.Storage_Offset;


   function To_Iterator is
      new Ada.Unchecked_Conversion (System.Address, Iterator_Type);

   function First (Items : access Array_Type) return Iterator_Type is
   begin
      return Items (Items'First)'Access;
   end;


   function Back (Items : access Array_Type) return Iterator_Type is

      First_Address : constant System.Address := Items
(Items'First)'Address;

      Length : constant System.Storage_Elements.Storage_Count :=
Items'Length;

      Offset : constant System.Storage_Elements.Storage_Count :=
         Length * Array_Type'Component_Size / System.Storage_Unit;

      Back_Address : constant System.Address := First_Address + Offset;

   begin

      return To_Iterator (Back_Address);

   end;


   function Item (Iterator : Iterator_Type) return Item_Type is
   begin
      return Iterator.all;
   end;


   procedure Next (Iterator : in out Iterator_Type) is

      Curr_Address : constant System.Address := Iterator.all'Address;

      Offset : constant System.Storage_Elements.Storage_Count :=
         Array_Type'Component_Size / System.Storage_Unit;

      Next_Address : constant System.Address := Curr_Address + Offset;

   begin

      Iterator := To_Iterator (Next_Address);

   end;


end Array_Iterators;
generic

   type Item_Type is limited private;

   type Index_Type is range <>;

   type Array_Type is array (Index_Type range <>) of aliased Item_Type;

package Array_Iterators is

   type Iterator_Type is access all Item_Type;
   for Iterator_Type'Storage_Size use 0;

   function First (Items : access Array_Type) return Iterator_Type;

   function Back (Items : access Array_Type) return Iterator_Type;

   function Item (Iterator : Iterator_Type) return Item_Type;

   procedure Next (Iterator : in out Iterator_Type);

end Array_Iterators;

      procedure Generic_Copy
  (First  : in     Source_Iterator_Type;
   Back   : in     Source_Iterator_Type;
   Target : in out Target_Iterator_Type) is

   Source : Source_Iterator_Type := First;
begin
   while Source /= Back loop
      Set_Item (Source, Target);
      Next (Source);
      Next (Target);
   end loop;
end Generic_Copy;

generic

   type Source_Iterator_Type (<>) is private;

   type Target_Iterator_Type (<>) is private;

   with procedure Set_Item
     (Source : Source_Iterator_Type;
      Target : Target_Iterator_Type) is <>;

   with procedure Next (Iterator : in out Source_Iterator_Type) is <>;

   with procedure Next (Iterator : in out Target_Iterator_Type) is <>;

   with function "=" (L, R : Source_Iterator_Type) return Boolean is <>;

procedure Generic_Copy
  (First  : in     Source_Iterator_Type;
   Back   : in     Source_Iterator_Type;
   Target : in out Target_Iterator_Type);
   with Array_Iterators;
pragma Elaborate_All (Array_Iterators);

package Integer_Arrays is

   type Integer_Array is array (Positive range <>) of aliased Integer;

   package Integer_Array_Iterators is
      new Array_Iterators (Integer, Positive, Integer_Array);

   type Iterator_Type is new Integer_Array_Iterators.Iterator_Type;

end Integer_Arrays;
with Unbounded_Lists;
pragma Elaborate_All (Unbounded_Lists);

package Integer_Lists is
   new Unbounded_Lists (Integer);

with Integer_Lists;  use Integer_Lists;
with Integer_Arrays;  use Integer_Arrays;
with Generic_Copy;
with Ada.Text_IO;  use Ada.Text_IO;
with Ada.Integer_Text_IO;  use Ada.Integer_Text_IO;

procedure Test_Copy is

   List : List_Type;

begin

   for I in 1 .. 5 loop
      Push_Back (List, I);
   end loop;

   declare
      Iter : Integer_Lists.Iterator_Type := First (List);
      Back : constant Integer_Lists.Iterator_Type := Integer_Lists.Back
(List);
   begin
      Put ("source:");

      while Iter /= Back loop
         Put (' ');
         Put (Item (Iter), Width => 0);
         Next (Iter);
      end loop;

      New_Line;
   end;

   declare
      procedure Set_Item
        (Source : Integer_Lists.Iterator_Type;
         Target : Integer_Arrays.Iterator_Type) is
      begin
         Target.all := Item (Source);
      end;

      pragma Warnings (Off, Set_Item);

      procedure Copy is
         new Generic_Copy
           (Integer_Lists.Iterator_Type,
            Integer_Arrays.Iterator_Type);

      Items : aliased Integer_Array (1 .. Length (List));
      Iter : Integer_Arrays.Iterator_Type := Items
(Items'First)'Unchecked_Access;
   begin
      Copy (First (List), Back (List), Iter);

      Put ("target:");

      for I in Items'Range loop
         Put (' ');
         Put (Items (I), Width => 0);
      end loop;

      New_Line;
   end;


end Test_Copy;

with Ada.Unchecked_Deallocation;  --should pass in storage_pool

package body Unbounded_Lists is

   procedure Free is
      new Ada.Unchecked_Deallocation (Node_Type, Node_Access);


   procedure Initialize (List : in out List_Type) is
   begin

      List.Front := new Node_Type;
      List.Back := new Node_Type;

      List.Front.Next := List.Back;
      List.Back.Prev := List.Front;

      List.Length := 0;

   end Initialize;


   procedure Finalize (List : in out List_Type) is
   begin
      Clear (List);
      Free (List.Front);
      Free (List.Back);
   end;


   procedure Push_Front
     (List : in out List_Type;
      Item : in     Item_Type) is

      Node : constant Node_Access :=
         new Node_Type'(Item => Item,
                        Next => List.Front.Next,
                        Prev => List.Front);
   begin
      Node.Next.Prev := Node;
      List.Front.Next := Node;
      List.Length := List.Length + 1;
   end;


   procedure Push_Front
     (List : access List_Type;
      Item : in     Item_Type) is
   begin
      Push_Front (List.all, Item);
   end;


   procedure Push_Back
     (List : in out List_Type;
      Item : in     Item_Type) is

      Node : constant Node_Access :=
         new Node_Type'(Item => Item,
                        Next => List.Back,
                        Prev => List.Back.Prev);
   begin
      Node.Prev.Next := Node;
      List.Back.Prev := Node;
      List.Length := List.Length + 1;
   end;


   procedure Push_Back
     (List : access List_Type;
      Item : in     Item_Type) is
   begin
      Push_Back (List.all, Item);
   end;


   procedure Push_Front (List : in out List_Type) is
      Node : constant Node_Access := new Node_Type;
   begin
      Node.Next := List.Front.Next;
      Node.Prev := List.Front;
      Node.Next.Prev := Node;
      List.Front.Next := Node;
      List.Length := List.Length + 1;
   end;


   procedure Push_Back (List : in out List_Type) is
      Node : constant Node_Access := new Node_Type;
   begin
      Node.Next := List.Back;
      Node.Prev := List.Back.Prev;
      Node.Prev.Next := Node;
      List.Back.Prev := Node;
      List.Length := List.Length + 1;
   end;


   procedure Pop_Front (List : in out List_Type) is
      pragma Assert (List.Length > 0);

      Node : Node_Access := List.Front.Next;
   begin
      List.Front.Next := Node.Next;
      Node.Next.Prev := List.Front;
      List.Length := List.Length - 1;
      Free (Node);
   end;

   procedure Pop_Back (List : in out List_Type) is
      pragma Assert (List.Length > 0);

      Node : Node_Access := List.Back.Prev;
   begin
      List.Back.Prev := Node.Prev;
      Node.Prev.Next := List.Back;
      List.Length := List.Length - 1;
      Free (Node);
   end;


   function Length (List : List_Type) return Natural is
   begin
      return List.Length;
   end;


   procedure Clear (List : in out List_Type) is
      Node : Node_Access := List.Front.Next;
      Next : Node_Access;
   begin
      while Node /= List.Back loop
         Next := Node.Next;
         Free (Node);
         Node := Next;
      end loop;

      List.Front.Next := List.Back;
      List.Back.Prev := List.Front;
      List.Length := 0;
   end;


   function First (List : List_Type) return Item_Type is
      pragma Assert (List.Length > 0);
   begin
      return List.Front.Next.Item;
   end;

   function Last (List : List_Type) return Item_Type is
      pragma Assert (List.Length > 0);
   begin
      return List.Back.Prev.Item;
   end;

   procedure Swap (L, R : in out List_Type) is
      Front : constant Node_Access := L.Front;
      Back  : constant Node_Access := L.Back;
      Length : constant Natural := L.Length;
   begin
      L.Front := R.Front;
      L.Back := R.Back;
      L.Length := R.Length;

      R.Front := Front;
      R.Back := Back;
      R.Length := Length;
   end;



   function First (List : List_Type) return Iterator_Type is
      pragma Assert (List.Length > 0);
   begin
      return Iterator_Type'(Node => List.Front.Next);
   end;

   function Last (List : List_Type) return Iterator_Type is
      pragma Assert (List.Length > 0);
   begin
      return Iterator_Type'(Node => List.Back.Prev);
   end;

   function Front (List : List_Type) return Iterator_Type is
   begin
      return Iterator_Type'(Node => List.Front);
   end;

   function Back (List : List_Type) return Iterator_Type is
   begin
      return Iterator_Type'(Node => List.Back);
   end;

   procedure Next (Iterator : in out Iterator_Type) is
   begin
      Iterator.Node := Iterator.Node.Next;
   end;

   procedure Previous (Iterator : in out Iterator_Type) is
   begin
      Iterator.Node := Iterator.Node.Prev;
   end;

   function Item (Iterator : Iterator_Type) return Item_Type is
   begin
      return Iterator.Node.Item;
   end;


end Unbounded_Lists;
with Ada.Finalization;

generic

   type Item_Type is private;

package Unbounded_Lists is

   type List_Type is limited private;


   procedure Push_Front
     (List : in out List_Type;
      Item : in     Item_Type);

   procedure Push_Front
     (List : access List_Type;
      Item : in     Item_Type);

   procedure Push_Front (List : in out List_Type);

   procedure Pop_Front (List : in out List_Type);


   procedure Push_Back
     (List : in out List_Type;
      Item : in     Item_Type);

   procedure Push_Back
     (List : access List_Type;
      Item : in     Item_Type);

   procedure Push_Back (List : in out List_Type);

   procedure Pop_Back (List : in out List_Type);



   function Length (List : List_Type) return Natural;

   procedure Clear (List : in out List_Type);

   function First (List : List_Type) return Item_Type;

   function Last (List : List_Type) return Item_Type;

   procedure Swap (L, R : in out List_Type);


   type Iterator_Type is private;

   function First (List : List_Type) return Iterator_Type;

   function Last (List : List_Type) return Iterator_Type;

   function Front (List : List_Type) return Iterator_Type;

   function Back (List : List_Type) return Iterator_Type;

   procedure Next (Iterator : in out Iterator_Type);

   procedure Previous (Iterator : in out Iterator_Type);

   function Item (Iterator : Iterator_Type) return Item_Type;


private

   type Node_Type;
   type Node_Access is access Node_Type;

   type Node_Type is
      record
         Item : aliased Item_Type;
         Next : Node_Access;
         Prev : Node_Access;
      end record;

   type Handle_Type (L : access List_Type) is limited null record;

   type List_Type is
      new Ada.Finalization.Limited_Controlled with record
         H      : Handle_Type (List_Type'Access);
         Front  : Node_Access;
         Back   : Node_Access;
         Length : Natural;
      end record;

   procedure Initialize (List : in out List_Type);
   procedure Finalize (List : in out List_Type);

   type Iterator_Type is
      record
         Node : Node_Access;
      end record;

end Unbounded_Lists;