with WinAPI;
with WinAPIConstants;  use WinAPIConstants;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Conversion;
with system;

procedure ComBeep is

   use type WinAPI.DWORD, WinAPI.HRESULT;

   S_OK : constant := 0;

   function CLSCTX_ALL return WinAPI.DWORD is
   pragma Inline (CLSCTX_ALL);
      function To_DWORD is new Ada.Unchecked_Conversion (WinAPI.CLSCTX, WinAPI.DWORD);
   begin
      return To_DWORD (WinAPI.CLSCTX_INPROC_SERVER ) or
             To_DWORD (WinAPI.CLSCTX_INPROC_HANDLER) or
             To_DWORD (WinAPI.CLSCTX_LOCAL_SERVER  );
   end CLSCTX_ALL;

   -- IID for IBeep
   IID_IBeep       : aliased WinAPI.IID := (16#0FE0EE22#,16#8AA2#,16#11d2#,
                        (16#81#,16#AA#,16#44#,16#45#,16#53#,16#54#,16#00#,16#01#) );

   -- Class ID of an object to create that has an interface to IBeep
   CLSID_BeepClass : aliased WinAPI.CLSID := (16#0FE0EE21#,16#8AA2#,16#11d2#,
                        (16#81#,16#AA#,16#44#,16#45#,16#53#,16#54#,16#00#,16#01#) );

   -- Interface IBeep
   type IBeep;
   type Pointer_To_IBeep is access all IBeep;

   -- C++ style VTBL of methods in the IBeep Interface
   type IBeepVtbl;
   type Pointer_To_IBeepVtbl is access all IBeepVtbl;
   
   -- Create method prototypes for IBeep
   -- Don't forger that first argument of C++ methods is C++'s this pointer

   -- IUnkown
   -- IBeep "interface inherits" from IUnkown and therefore requires those
   -- methods also.

   type af_IBeep_QueryInterface is access function (
      This     : access IBeep;
      riid     : WinAPI.AddressOfIID; --REFIID;
      ppvObject: access WinAPI.PVOID)
      return WinAPI.HRESULT;
      
   pragma Convention(Stdcall, af_IBeep_QueryInterface);

   type af_IBeep_AddRef is access function (
      This: access IBeep)
      return WinAPI.ULONG;
   pragma Convention(Stdcall, af_IBeep_AddRef);

   type af_IBeep_Release is access function (
      This: access IBeep)
      return WinAPI.ULONG;
   pragma Convention(Stdcall, af_IBeep_Release);

   -- IBeep
   -- IBeep only has one method called Beep that sounds a beep and displays a
   -- message box.

   type af_IBeep_Beep is access function (
      This: access IBeep)
      return WinAPI.HRESULT;
   pragma Convention(Stdcall, af_IBeep_Beep);

   -- IBeep just contains a pointer to its VTBL
   type IBeep is
      record
         lpVtbl: Pointer_To_IBeepVtbl;
      end record;

   -- IBeepVtbl contains pointers to all the methods IBeep interfaces to.
   type IBeepVtbl is
      record
         QueryInterface: af_IBeep_QueryInterface;
         AddRef        : af_IBeep_AddRef;
         Release       : af_IBeep_Release;
         Beep          : af_IBeep_Beep;
      end record;

   -- Normally Ada passes by reference non scalar types, so we need the
   -- following:
   pragma Convention(C_Pass_By_Copy, IBeep);
   pragma Convention(C_Pass_By_Copy, IBeepVtbl);

   -- Conversion functions to make the compiler happy.
   function To_LPUNKNOWN is
       new Ada.Unchecked_Conversion (system.address, WinAPI.LPUNKNOWN);
   function To_Pointer_To_IBeep is
       new Ada.Unchecked_Conversion (WinAPI.PVOID, Pointer_To_IBeep);


   RetPointer    : aliased WinAPI.PVOID;
   hr            : WinAPI.HRESULT;
   BeepInterface : Pointer_To_IBeep;
   refcount      : WinAPI.ULONG;
   com_error     : exception;   
begin

   put_line("Initialize Com Libraries");
   hr := WinAPI.CoInitialize (system.null_address);
   if hr /= S_OK then
      raise com_error;
   end if;
    
   put_line("CoCreateInstance");
   hr := WinAPI.CoCreateInstance(CLSID_BeepClass'unchecked_access,
                                 To_LPUNKNOWN(system.null_address),
                                 CLSCTX_ALL,
                                 IID_IBeep'unchecked_access,
                                 RetPointer'unchecked_access);
   if hr /= S_OK then
      raise com_error;
   end if;

   put_line("Convert return pointer to pointer to IBeep");
   BeepInterface := To_Pointer_To_IBeep(RetPointer);

   put_Line("IBeep->Beep");
   hr := BeepInterface.lpvtbl.Beep(BeepInterface);
   if hr /= S_OK then
      raise com_error;
   end if;

   put_Line("Release IBeep Interface");
   refcount := BeepInterface.lpvtbl.Release(BeepInterface);

   put_line("Uninit COM Libs");
   WinAPI.CoUninitialize;
end ComBeep;