Re: Ada Singleton Pattern

[Luca Stasio <stasio2000@tin.it>]

Martin Dowie wrote:
> "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;
> 
> 
Thanx a lot