Re: Ada Singleton Pattern

["Martin Dowie" <martin.dowie@btopenworld.com>]

"Luca Stasio" <stasio2000@tin.it> wrote in message 
news:hnk1d.246585$OR2.11156430@news3.tin.it...
> Know, sorry... but, there is a way to create a Singleton Class from wich 
> derive and create concrete singleton classes?
>  I mean: (1) a Singleton class (2) a DatbaseAccessSingleton or a 
> NetworkAccessSingleton or... heach one with its own methods but sharing 
> the Singleton behaviour.

Here's one I use. It's not the complete source, which also includes 
interleavable singletons and limited singletons (also can be interleavable). 
Examples are embedded in the package spec (in an AdaBrowse format, of 
course).

I may post them on my web page if anyone is interested.

Cheers

-- Martin


--  generic_singletons.ads

-- (c) 2003, Martin M. Dowie
--
-- Instantiate a new version of this package for each type you want to be
-- a singleton.
--
-- Example
--! with Generic_Singletons;
--!
--! package My_Stuff is
--!
--! type My_Type is private;
--!
--! ...
--!
--! private
--!
--! package Root_Singleton is
--! new Generic_Singletons;
--!
--! type My_Type
--! is new Root_Singleton.Singleton with ...;
--!
--! end My_Stuff;
--!
--!
--! with My_Stuff;
--!
--! procedure Test is
--! S1 : My_Stuff.My_Type; -- Should be the one and only
--! S2 : My_Stuff.My_Type; -- Will raise Program_Error here
--! begin
--! null;
--! end Test;
pragma License (Modified_GPL);
with Ada.Finalization;
generic
   Thread_Safe : in Boolean := False;
package Generic_Singletons is
   type Singleton is tagged private;
   -- Derive your type from this type to ensure that only one instance
   -- of your type can exist within a partition <STRONG>ever</STRONG>.
   type Pointer is access all Singleton'Class;
   type Reference is access constant Singleton'Class;
private
   Number_Created : Natural := 0;
   pragma Atomic (Number_Created);
   type Singleton is
      new Ada.Finalization.Controlled with null record;
   procedure Initialize (S : in out Singleton);
   protected Semaphore is
      entry Lock;
      entry Unlock;
   private
      Is_Locked : Boolean := False;
   end Semaphore;
end Generic_Singletons;

-- generic_singletons.adb

with Ada.Exceptions; use Ada.Exceptions;
package body Generic_Singletons is
   protected body Semaphore is
      entry Lock when not Is_Locked is
      begin
         Is_Locked := True;
      end Lock;
      entry Unlock when Is_Locked is
      begin
         Is_Locked := False;
      end Unlock;
   end Semaphore;

   ----------------
   -- Initialize --
   ----------------
   procedure Initialize (S : in out Singleton) is
      pragma Warnings (Off, S);
   begin
      if Thread_Safe then
         Semaphore.Lock;
      end if;
      Number_Created := Number_Created + 1;
      if Thread_Safe then
         Semaphore.Unlock;
      end if;
      if Number_Created > 1 then
         Raise_Exception
            (Program_Error'Identity,
             "Only one instance of a Singleton is allowed at a time");
      end if;
   end Initialize;
end Generic_Singletons;