Re: friend classes in ada95 (long)

[tmoran@bix.com]

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