Re: Controlled types for resource locking

["David C. Hoos, Sr." <david.c.hoos.sr@ada95.com>]

Steve Folly <steve@follysplace.demon.co.uk> wrote in message
news:936824686.950.0.nnrp-07.c2de848f@news.demon.co.uk...
> Hi,
>
> A couple of months ago (maybe more?) I remember somebody posted some code,
> or a link to some code to do with controlled types and how they can be
> useful for resource locking.
>
> If anyone remembers this, or indeed if you were the person who posted it,
I
> would be grateful for any link or reference to it.
>
> I have some code in which I'm protecting a hardware resource using a
> protected type. It's getting quite a mess at the moment with lock/unlocks
> all over the place - especially where exception handlers get involved. I'm
> sure this code could come in handy.
>
The code (or a reference to it) was posted by Matthew Heaney.  Here's a copy
(possibly with some editing by me -- I don't remember.  I think the code
comes from the patterns archive of the ACM for which the URL is:

http://www.acm.org/archives/wa.cgi?A2=ind9903&L=patterns&P=R11595

There's commentary there.

Here's my copy of the code
package body Binary_Semaphores.Controls is

   procedure Initialize (Control : in out Semaphore_Control) is
   begin
      Control.Semaphore.Seize;
   end;

   procedure Finalize (Control : in out Semaphore_Control) is
   begin
      Control.Semaphore.Release;
   end;

end Binary_Semaphores.Controls;
with Ada.Finalization;

package Binary_Semaphores.Controls is

   pragma Preelaborate;

   type Semaphore_Control (Semaphore : access Semaphore_Type) is
      limited private;

private

   use Ada.Finalization;

   type Semaphore_Control (Semaphore : access Semaphore_Type) is
     new Limited_Controlled with null record;

   procedure Initialize (Control : in out Semaphore_Control);

   procedure Finalize (Control : in out Semaphore_Control);

end Binary_Semaphores.Controls;
package body Binary_Semaphores is

   protected body Semaphore_Type is

      procedure Release is
      begin
         In_Use := False;
      end;

      entry Seize when not In_Use is
      begin
         In_Use := True;
      end;

   end Semaphore_Type;

end Binary_Semaphores;
package Binary_Semaphores is

   pragma Pure;


   protected type Semaphore_Type is

      procedure Release;

      entry Seize;

   private

      In_Use : Boolean := False;

   end Semaphore_Type;

end Binary_Semaphores;
with Binary_Semaphores.Controls;  use Binary_Semaphores.Controls;

with System.Address_To_Access_Conversions;
pragma Elaborate_All (System.Address_To_Access_Conversions);

package body Stacks is

   package Addr_To_Acc_Conversions is
     new System.Address_To_Access_Conversions (Stack_Type);


   procedure Push
     (Item : in     Item_Type;
      On   : in out Stack_Type) is

      Control : Semaphore_Control (On.Sema'Access);
   begin
      On.Top := On.Top + 1;
      On.Items (On.Top) := Item;
   end;


   procedure Pop
     (Stack : in out Stack_Type) is

      Control : Semaphore_Control (Stack.Sema'Access);
   begin
      Stack.Top := Stack.Top - 1;
   end;


   function Get_Top
     (Stack : Stack_Type) return Item_Type is

      use Addr_To_Acc_Conversions;

      SA : constant Object_Pointer :=
        To_Pointer (Stack'Address);

      Control : Semaphore_Control (SA.Sema'Access);

   begin

      return SA.Items (SA.Top);

   end Get_Top;



   procedure Set_Top
     (Stack : in out Stack_Type;
      Item  : in     Item_Type) is

      Control : Semaphore_Control (Stack.Sema'Access);
   begin
      Stack.Items (Stack.Top) := Item;
   end;


   procedure For_Every_Item (Stack : in out Stack_Type) is

      Control : Semaphore_Control (Stack.Sema'Access);

      Done : Boolean := False;

   begin

      for I in reverse 1 .. Stack.Top loop

         Process (Stack.Items (I), Done);

         exit when Done;

      end loop;

   end For_Every_Item;


end Stacks;





with Binary_Semaphores;

generic

   type Item_Type is private;

   Max_Depth : in Positive;

package Stacks is

   pragma Preelaborate;

   type Stack_Type is limited private;


   procedure Push
     (Item : in     Item_Type;
      On   : in out Stack_Type);

   procedure Pop
     (Stack : in out Stack_Type);

   function Get_Top
     (Stack : Stack_Type) return Item_Type;

   procedure Set_Top
     (Stack : in out Stack_Type;
      Item  : in     Item_Type);


   generic

      with procedure Process
        (Item : in out Item_Type;
         Done : in out Boolean);

   procedure For_Every_Item (Stack : in out Stack_Type);

private

   subtype Item_Array_Range is Positive range 1 .. Max_Depth;

   type Item_Array is array (Item_Array_Range) of Item_Type;

   use Binary_Semaphores;

   type Stack_Type is
      limited record
         Items : Item_Array;
         Top   : Natural := 0;
         Sema  : aliased Semaphore_Type;
      end record;

end Stacks;