From mboxrd@z Thu Jan  1 00:00:00 1970
X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on polar.synack.me
X-Spam-Level: 
X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=ham
	autolearn_force=no version=3.4.4
X-Google-Language: ENGLISH,ASCII-7-bit
X-Google-Thread: 103376,7a992ba0c2391839,start
X-Google-Attributes: gid103376,public
From: matthew_heaney@acm.org (Matthew Heaney)
Subject: Active Iteration - Update
Date: 1998/05/15
Message-ID: <matthew_heaney-ya023680001505980600400001@news.ni.net>
X-Deja-AN: 353498048
Content-Transfer-Encoding: 8bit
Content-Type: text/plain; charset=ISO-8859-1
Organization: Network Intensive
Mime-Version: 1.0
Newsgroups: comp.lang.ada
Date: 1998-05-15T00:00:00+00:00
List-Id: <comp.lang.ada>



I figured out a way to do iteratoration using a dispatching iterator
(handle) constructor, and at the same time hide away the calls to
New_Iterator and Free.

I originally posed something like this:

   function New_Iterator 
     (Stack : access Root_Stack) return Iterator_Access;

My issue with this solution is that the client has to remember to
explicitly Free the object returned by that constructor, as in:

procedure Do_Something (S : access Stack'Class) is

   IA : Iterator_Access := New_Iterator (S);

   Iter : Root_Iterator'Class renames IA.all;
begin
   while not Is_Done (Iter) loop
      ... Get_Item (Iter) ...
      <do something with item>
      Advance (Iter);
   end loop;

   Free (IA);
end Do_Something;

There are two reasons why I don't like this:

1) The client has to call a function manually, to get an iterator
indirectly, ie through an access object.

2) The client has to remember to manually call Free, to reclaim storage
associated with the iterator object.

Item (2) is especially pernicious, because 

a) the client can forget to call Free, thus creating a memory leak

b) there could be an unhandled exception raised prior to the call to Free,
thus creating a memory leak

We can do better.

The idea is to wrap the iterator access object inside a Controlled object,
which I've called Iterator_Handle.  That way  Finalize gets called
automatically, and thus no memory leak can occur.

The iterator handle is implemented as a Controlled record containing an
access object that designates an iterator.  As before, the iterator is
constructed by calling a dispatching function that returns the iterator
access type.  The iterator handle implements its operations in terms of the
corresponding operations of the actual iterator.

The iterator handle, during its (automatic) Finalization, calls a
dispatching Deallocate operation to reclaim the storage associated with the
iterator.

The improved version of the classwide operation above is:

procedure Do_Something (S : access Stack'Class) is

   Handle : Iterator_Handle (S);
begin

   while not Is_Done (Handle) loop
      ... Get_Item (Handle) ...
      <do something with item>
      Advance (Handle);
   end loop;

end Do_Something;

Note that there is no call to New, nor is there a call to Free.

Hope that helps,
Matt

P.S. The sources below compile and run using GNAT 3.10p, and are in a
format suitable for use with gnatchop.


-- STX
with Ada.Finalization;

generic

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

package Stacks is

   type Root_Stack is abstract tagged null record;

   type Stack_Item_Access is access all Stack_Item;
   for Stack_Item_Access'Storage_Size use 0;

   procedure Push
     (Item : in     Stack_Item;
      On   : in out Root_Stack) is abstract;

   function Get_Top
     (Stack : Root_Stack) return Stack_Item is abstract;

   function Get_Top
     (Stack : access Root_Stack) return Stack_Item_Access is abstract;


   type Iterator_Handle
     (Stack : access Root_Stack'Class) is limited private;

   function Is_Done
     (Handle : Iterator_Handle) return Boolean;

   function Get_Item
     (Handle : Iterator_Handle) return Stack_Item_Access;

   procedure Advance
     (Handle : Iterator_Handle);

   procedure Reset
     (Handle : Iterator_Handle);

private

   type Root_Iterator is
     abstract tagged limited null record;

   function Is_Done
     (Iterator : Root_Iterator) return Boolean is abstract;

   function Get_Item
     (Iterator : Root_Iterator) return Stack_Item_Access is abstract;

   procedure Advance
     (Iterator : in out Root_Iterator) is abstract;

   procedure Reset
     (Iterator : in out Root_Iterator) is abstract;

   procedure Deallocate
     (Iterator : access Root_Iterator) is abstract;


   type Iterator_Access is
      access all Root_Iterator'Class;

   function New_Iterator
     (Stack : access Root_Stack) return Iterator_Access is abstract;

   type Iterator_Handle (Stack : access Root_Stack'Class) is
     new Ada.Finalization.Limited_Controlled with record
        Iter : Iterator_Access := New_Iterator (Stack);
     end record;

   procedure Finalize
     (Handle : in out Iterator_Handle);

end Stacks;


with Ada.Text_IO; use Ada.Text_IO;

package body Stacks is

   function Is_Done
     (Handle : Iterator_Handle) return Boolean is
   begin
      return Is_Done (Handle.Iter.all);
   end;


   function Get_Item
     (Handle : Iterator_Handle) return Stack_Item_Access is
   begin
      return Get_Item (Handle.Iter.all);
   end;


   procedure Advance
     (Handle : Iterator_Handle) is
   begin
      Advance (Handle.Iter.all);
   end;


   procedure Reset
     (Handle : Iterator_Handle) is
   begin
      Reset (Handle.Iter.all);
   end;

   procedure Finalize
     (Handle : in out Iterator_Handle) is
   begin
      Deallocate (Handle.Iter);
   end;


end Stacks;


generic
   Max_Depth : in Positive;
package Stacks.Bounded_G is

   type Bounded_Stack is
     new Root_Stack with private;

   function "="
     (L, R : Bounded_Stack) return Boolean;


   procedure Push
     (Item : in     Stack_Item;
      On   : in out Bounded_Stack);

   function Get_Top
     (Stack : Bounded_Stack) return Stack_Item;

   function Get_Top
     (Stack : access Bounded_Stack) return Stack_Item_Access;


   type Bounded_Iterator
     (Stack : access Bounded_Stack'Class) is
      limited private;

   function Is_Done
     (Iterator : Bounded_Iterator) return Boolean;

   function Get_Item
     (Iterator : Bounded_Iterator) return Stack_Item_Access;

   procedure Advance (Iterator : in out Bounded_Iterator);

   procedure Reset (Iterator : in out Bounded_Iterator);


private

   type Stack_Item_Array is
      array (Positive range <>) of aliased Stack_Item;

   function "=" (L, R : Stack_Item_Array) return Boolean is abstract;

   subtype Items_Range is Positive range 1 .. Max_Depth;

   type Bounded_Stack is
     new Root_Stack with record
        Items : Stack_Item_Array (Items_Range);
        Depth : Natural range 0 .. Max_Depth := 0;
     end record;


   type Bounded_Iterator
     (Stack : access Bounded_Stack'Class) is
     new Root_Iterator with record
        Index : Natural := Stack.Depth;
     end record;


   function New_Iterator
     (Stack : access Bounded_Stack) return Iterator_Access;

   procedure Deallocate
     (Iterator : access Bounded_Iterator);


end Stacks.Bounded_G;


with Ada.Unchecked_Deallocation;
with Ada.Text_IO;

package body Stacks.Bounded_G is

   function "="
     (L, R : Bounded_Stack) return Boolean is
   begin
      if L.Depth /= R.Depth then
         return False;
      end if;

      for I in 1 .. L.Depth loop
         if L.Items (I) /= R.Items (I) then
            return False;
         end if;
      end loop;

      return True;
   end "=";


   procedure Push
     (Item : in     Stack_Item;
      On   : in out Bounded_Stack) is

      Stack : Bounded_Stack renames On;
      Depth : Natural renames Stack.Depth;
   begin
      Depth := Depth + 1;
      Stack.Items (Depth) := Item;
   end Push;


   function Get_Top
     (Stack : Bounded_Stack) return Stack_Item is
   begin
      return Stack.Items (Stack.Depth);
   end Get_Top;


   function Get_Top
     (Stack : access Bounded_Stack) return Stack_Item_Access is
   begin
      return Stack.Items (Stack.Depth)'Access;
   end Get_Top;


   function Is_Done
     (Iterator : Bounded_Iterator) return Boolean is
   begin
      return Iterator.Index = 0;
   end;


   function Get_Item
     (Iterator : Bounded_Iterator) return Stack_Item_Access is

      Stack : Bounded_Stack'Class renames Iterator.Stack.all;
   begin
      return Stack.Items (Iterator.Index)'Access;
   end;


   procedure Advance (Iterator : in out Bounded_Iterator) is
   begin
      Iterator.Index := Iterator.Index - 1;
   end;


   procedure Reset (Iterator : in out Bounded_Iterator) is
   begin
      Iterator.Index := Iterator.Stack.Depth;
   end;


   function New_Iterator
     (Stack : access Bounded_Stack) return Iterator_Access is
   begin
     return new Bounded_Iterator (Stack);
   end;


   procedure Free is
     new Ada.Unchecked_Deallocation
     (Root_Iterator'Class, Iterator_Access);

   procedure Deallocate (Iterator : access Bounded_Iterator) is
      IA : Iterator_Access := Iterator_Access (Iterator);
   begin
      Free (IA);
      Ada.Text_IO.Put_Line ("reclaimed memory for iterator handle");
   end;


end Stacks.Bounded_G;

generic
   with function Image (Item : Stack_Item) return String;
package Stacks.Stack_IO_G is

   procedure Dump (Stack : access Root_Stack'Class);

end Stacks.Stack_IO_G;


with Ada.Text_IO;  use Ada.Text_IO;

package body Stacks.Stack_IO_G is

   procedure Dump (Stack : access Root_Stack'Class) is

      Iterator : Iterator_Handle (Stack);
   begin
      while not Is_Done (Iterator) loop
         Put (Image (Get_Item (Iterator).all));
         Advance (Iterator);
      end loop;

      New_Line;
   end Dump;

end Stacks.Stack_IO_G;


with Stacks;
pragma Elaborate_All (Stacks);

package Integer_Stacks is new Stacks (Integer);


with Stacks.Bounded_G;
pragma Elaborate_All (Stacks.Bounded_G);

package Integer_Stacks.Bounded is
  new Integer_Stacks.Bounded_G (Max_Depth => 10);


with Stacks.Stack_IO_G;
pragma Elaborate_All (Stacks.Stack_IO_G);

package Integer_Stacks.Stack_IO is
   new Integer_Stacks.Stack_IO_G (Integer'Image);


with Integer_Stacks.Bounded;   use Integer_Stacks.Bounded;
with Integer_Stacks.Stack_IO;  use Integer_Stacks.Stack_IO;

procedure Test_Stacks is

   Stack : aliased Bounded_Stack;

begin

   Push (9, On => Stack);
   Push (8, On => Stack);
   Push (7, On => Stack);
   Push (6, On => Stack);
   Push (5, On => Stack);

   Dump (Stack'Access);

end;