Semaphores - Revised

In the last article, I implemented the semaphore type as limited
private, hiding the fact that the semaphore was a protected type.

I've been thinking more about that declaration, and have come to the
tentative conclusion that it's better to just state publicly that the
semaphore is a protected object.

The revised type declaration looks like this:

  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;


There are a few reasons for taking this point of view:

o Clients can't violate the abstraction anyway, even if it's not limited
private, because a protected type still hides the representation.


o You can make timed and conditional entry calls to a protected entry:

  select
    Semaphore.Seize;
  or
    delay 5.0;
    <handle timeout>
  end select;


  select
    Semaphore.Seize;
  else
    <do something else instead of waiting>
  end select;


If this is intended as a reusable component, then you want it to be as
flexible as possible.  If you hide the representation of the semaphore,
timed or conditional entry calls aren't possible.


o It's kind of nice to advertise the fact that Seize is a blocking call,
instead of making it look like any other kind of operation.  Instead of

  Seize (Semaphore);

it's better to say

  Semaphore.Seize;

The "distinguished receiver" syntax emphasizes the fact that this is a
synchronizing operation.

I'm inspired here by comments made by Tucker a couple of years ago:

(start of post by Tucker Taft)
Re: Syntax for tagged record types and class types
Author: Tucker Taft <stt@houdini.camb.inmet.com>
Date: 1997/05/27
Forum: comp.lang.ada

Prefix notation, by which I mean <object>.<operation>, is reserved in
Ada 95 for calls on "synchronizing" operations.  The prefix object is
the one controlling the synchronization.  Hence, prefix notation is used
for task entry calls, and protected operation calls only.  In each of
these cases, the prefix object is very special -- one must enter the
synchronization domain of the prefix object before the operation is
performed.  Even if there are multiple parameters of the same task or
protected type passed to the operation, the synchronization is
associated only with the prefix object.

For non-synchronizing operations, all parameters are treated
symmetrically, and so the "principle of uniform reference" would argue
that all such parameters belong inside the parentheses, rather than
dangling out front.
[snip]
-Tucker Taft   stt@inmet.com   http://www.inmet.com/~stt/
Intermetrics, Inc.  Burlington, MA  USA
(end of post by Tucker Taft)


If we assume clients are going to be using timed or conditional calls,
then we can also assume they are doing something more sophisticated than
declaring a Semaphore_Control object.

For this reason, I decided to move the Semaphore_Control type off into
its own child package.  This way clients who aren't using that type
don't have to have a dependency on Ada.Finalization, and as a bonus we
can declare the Binary_Semaphores package as pragma Pure.

Clients who do decide to use the Semaphore_Control type just with that
package in the body:

  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 ...;



--STX
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;