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.3 required=5.0 tests=BAYES_00,INVALID_MSGID
	autolearn=no autolearn_force=no version=3.4.4
X-Google-Language: ENGLISH,ASCII-7-bit
X-Google-Thread: 103376,8b8748382fcfacc1
X-Google-Attributes: gid103376,public
From: tmoran@bix.com
Subject: Re: friend classes in ada95 (long)
Date: 2000/04/18
Message-ID: <TSSK4.73$vE6.38666@news.pacbell.net>#1/1
X-Deja-AN: 612560665
References: <KpLK4.3403$wy1.6682475@news-east.usenetserver.com>
X-Complaints-To: abuse@pacbell.net
X-Trace: news.pacbell.net 956037683 206.170.24.125 (Mon,
 17 Apr 2000 23:01:23 PDT)
Organization: SBC Internet Services
NNTP-Posting-Date: Mon, 17 Apr 2000 23:01:23 PDT
Newsgroups: comp.lang.ada
Date: 2000-04-18T00:00:00+00:00
List-Id: <comp.lang.ada>

> -- Interface IUnknown
> ...

How about making a hidden MSWindows COM object to serve as the nucleus
of a higher level Ada object instead of adding syntax to tell the
Ada compiler to create today's low level MS Windows binary to
access COM objects.

with Interfaces.C;
package COM_Stuff is

end COM_Stuff;

private package COM_Stuff.Types is
  type Reference_Count_Type is new Interfaces.C.Unsigned;
  type HResult is new Interfaces.C.Long;
end COM_Stuff.Types;


with COM_Stuff.Types;
 use COM_Stuff.Types;
private package COM_Stuff.IUnknown_Interface is

  type IUnknown is abstract tagged null record;

  type Interface_Pointer is access IUnknown'class;

  function QueryInterface (This : IUnknown;
                           RIID : Integer;
                           ppvObject: access Interface_Pointer)
    return HResult is abstract;

  function AddRef (This : IUnknown) return Reference_Count_Type is abstract;

  function Release (This : IUnknown) return Reference_Count_Type is abstract;

end COM_Stuff.IUnknown_Interface;

with COM_Stuff.Types,
     COM_Stuff.IUnknown_Interface;
 use COM_Stuff.Types;
private package COM_Stuff.IBeep_Interface is

  type IBeep is abstract new COM_Stuff.IUnknown_Interface.IUnknown
  with null record;

  function Beep (This : IBeep) return HResult is abstract;

end COM_Stuff.IBeep_Interface;

with COM_Stuff.Types,
     COM_Stuff.IUnknown_Interface;
 use COM_Stuff.Types;
private package COM_Stuff.IMessage_Interface is

  type IMessage is abstract new COM_Stuff.IUnknown_Interface.IUnknown
  with null record;

  function Message (This : IMessage) return HResult is abstract;

end COM_Stuff.IMessage_Interface;



with COM_Stuff.Types,
     COM_Stuff.IUnknown_Interface,
     COM_Stuff.IBeep_Interface,
     COM_Stuff.IMessage_Interface;
 use COM_Stuff.Types;
private package COM_Stuff.Beeper is

  type Beep_Interface_Part is new COM_Stuff.IBeep_Interface.IBeep
  with null record;
  function QueryInterface (This : Beep_Interface_Part;
                           RIID : Integer;
                           ppvObject: access Interface_Pointer)
    return HResult;
  function AddRef (This : Beep_Interface_Part) return Reference_Count_Type;
  function Release (This : Beep_Interface_Part) return Reference_Count_Type;
  function Beep (This : Beep_Interface_Part) return HResult;


  type Message_Interface_Part is new IMessage_Interface.IMessage with null record;
  function QueryInterface (This : Message_Interface_Part;
                           RIID : Integer;
                           ppvObject: access Interface_Pointer)
    return HResult;
  function AddRef (This : Message_Interface_Part) return Reference_Count_Type;
  function Release (This : Message_Interface_Part) return Reference_Count_Type;
  function Message (This : Message_Interface_Part) return HResult is abstract;

  type Beeper_Type is new COM_Stuff.IUnknown_Interface.IUnknown with record
    Beeper : aliased Beep_Interface_Part;
    Message: aliased Message_Interface_Part;
    Ref_Count : Reference_Count_Type := 0;
  end record;
  function QueryInterface (This : Beeper_Type;
                           RIID : Integer;
                           ppvObject: access Interface_Pointer)
    return HResult;
  function AddRef (This : Beeper_Type) return Reference_Count_Type;
  function Release (This : Beeper_Type) return Reference_Count_Type;

end COM_Stuff.Beeper;


-- package body COM_Stuff.Beeper;  -- TBD


---------- All the above to aid implementation of the Ada style:

with Ada.Finalization;
package COM_Stuff.Public_Beeper is

  type Beeper_Type is new Ada.Finalization.Limited_Controlled with private;

  procedure Beep(This : in out Beeper_Type);

  procedure Message(This : in out Beeper_Type);

private
  type Beeper_Type is new Ada.Finalization.Limited_Controlled with null record;
  -- encapsulate and hide the stuff to Create/Reference count/Destroy
  -- and handle thread safety for COM_Stuff.Beeper.Beeper_Type

  procedure Initialize(This : in out Beeper_Type);
  procedure Finalize(This : in out Beeper_Type);
end COM_Stuff.Public_Beeper;



-- allowing the programmer using this to write things like:

with COM_Stuff.Public_Beeper;
procedure Main is
begin
  if 2+2 = 4 then
    declare
      use COM_Stuff.Public_Beeper;
      Beeper : Beeper_Type;
    begin
      Beep(Beeper);
      Message(Beeper);
    end;
  end if;
end Main;