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-Thread: 103376,54aae3da1cf935cd
X-Google-Attributes: gid103376,public
X-Google-Language: ENGLISH,ASCII-7-bit
Path: 
 g2news1.google.com!news2.google.com!proxad.net!newsfeed.stueberl.de!newsr1.ipcore.viaginterkom.de!news-peer1!btnet-feed5!btnet!news.btopenworld.com!not-for-mail
From: "Martin Dowie" <martin.dowie@btopenworld.com>
Newsgroups: comp.lang.ada
Subject: Re: Ada Singleton Pattern
Date: Mon, 13 Sep 2004 18:43:33 +0000 (UTC)
Organization: BT Openworld
Message-ID: <ci4pok$l9u$1@titan.btinternet.com>
References: <%Fi1d.245967$OR2.11136154@news3.tin.it>
 <14p6ezf3vze8j$.j05arkr066wi.dlg@40tude.net>
 <hnk1d.246585$OR2.11156430@news3.tin.it>
NNTP-Posting-Host: host81-152-56-142.range81-152.btcentralplus.com
X-Trace: titan.btinternet.com 1095101013 21822 81.152.56.142 (13 Sep 2004
 18:43:33 GMT)
X-Complaints-To: news-complaints@lists.btinternet.com
NNTP-Posting-Date: Mon, 13 Sep 2004 18:43:33 +0000 (UTC)
X-RFC2646: Format=Flowed; Response
X-Newsreader: Microsoft Outlook Express 6.00.2900.2180
X-MSMail-Priority: Normal
X-Priority: 3
X-MimeOLE: Produced By Microsoft MimeOLE V6.00.2900.2180
Xref: g2news1.google.com comp.lang.ada:3693
Date: 2004-09-13T18:43:33+00:00
List-Id: <comp.lang.ada>

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