File : gnatcom-safearray.adb


------------------------------------------------------------------------------
--                                                                          --
--      GNATCOM - Ada 95 COM/DCOM/COM+ Development Framework and Tools      --
--                                                                          --
--                    G N A T C O M . S A F E A R R A Y                     --
--                                                                          --
--                                B o d y                                   --
--                                                                          --
--                            $Revision: 1.4 $
--                                                                          --
--             Copyright (C) 1999, 2000, 2001 David Botton                  --
--                                                                          --
-- This is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion. It is distributed in the hope that it will be useful,  but WITHOUT --
-- ANY WARRANTY;  without  even the  implied warranty of MERCHANTABILITY or --
-- FITNESS FOR A PARTICULAR PURPOSE.    See the GNU General  Public License --
-- for  more details.  You should have  recived  a copy of the GNU General --
-- Public License  distributed with this;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- More information about GNATCOM and the most current public version can   --
-- be located on the web at http://www.adapower.com/gnatcom                 --
--                                                                          --
-- Support for GNATCOM is available from Ada Core Technologies, Inc.        --
--                                                                          --
-- In the U.S., contact Ada Core Technologies at:                           --
-- Tel: +1 (212) 620 7300 ext 117                                           --
-- Fax: +1 (212) 807 0162                                                   --
-- Email: sales@gnat.com                                                    --
--                                                                          --
-- In Europe and elsewhere, contact ACT Europe at:                          --
-- Tel: +33 1 49 70 67 16                                                   --
-- Fax: +33 1 49 70 05 52                                                   --
-- Email: sales@act-europe.fr                                               --
------------------------------------------------------------------------------

with Ada.Unchecked_Conversion;
with Interfaces.C;
with System;

with GNATCOM.VARIANT;
with GNATCOM.BSTR;
with GNATCOM.Errors;

with GNATCOM.ITypeInfo_Interface;
with GNATCOM.ITypeLib_Interface;

package body GNATCOM.SafeArray is

   procedure Error_Check (Result : in GNATCOM.Types.HRESULT);
   --  Check for SAFEARRAY specific errors

   function SafeArrayCreateVector
     (vt        : Interfaces.C.unsigned_short;
      lLBound   : Interfaces.C.long;
      cElements : Interfaces.C.unsigned)
     return GNATCOM.Types.Pointer_To_SAFEARRAY;
   pragma Import (StdCall, SafeArrayCreateVector, "SafeArrayCreateVector");

   function SafeArrayCopy
     (psa     : access GNATCOM.Types.SAFEARRAY;
      ppsaOut : access GNATCOM.Types.Pointer_To_SAFEARRAY)
     return GNATCOM.Types.HRESULT;
   pragma Import (StdCall, SafeArrayCopy, "SafeArrayCopy");

   function SafeArrayGetDim
     (psa : access GNATCOM.Types.SAFEARRAY)
     return Interfaces.C.unsigned;
   pragma Import (StdCall, SafeArrayGetDim, "SafeArrayGetDim");

   function SafeArrayGetLBound
     (psa      : access GNATCOM.Types.SAFEARRAY;
      nDim     : in     Interfaces.C.unsigned;
      plLbound : access Interfaces.C.long)
     return GNATCOM.Types.HRESULT;
   pragma Import (StdCall, SafeArrayGetLBound, "SafeArrayGetLBound");

   function SafeArrayGetUBound
     (psa      : access GNATCOM.Types.SAFEARRAY;
      nDim     : in     Interfaces.C.unsigned;
      plUBound : access Interfaces.C.long)
     return GNATCOM.Types.HRESULT;
   pragma Import (StdCall, SafeArrayGetUBound, "SafeArrayGetUBound");

   function SafeArrayDestroy
     (psa      : access GNATCOM.Types.SAFEARRAY)
     return GNATCOM.Types.HRESULT;
   pragma Import (StdCall, SafeArrayDestroy, "SafeArrayDestroy");

   function SafeArrayAllocData
     (psa      : access GNATCOM.Types.SAFEARRAY)
     return GNATCOM.Types.HRESULT;
   pragma Import (StdCall, SafeArrayAllocData, "SafeArrayAllocData");

   function SafeArrayDestroyData
     (psa      : access GNATCOM.Types.SAFEARRAY)
     return GNATCOM.Types.HRESULT;
   pragma Import (StdCall, SafeArrayDestroyData, "SafeArrayDestroyData");

   function SafeArrayAllocDescriptor
     (cDims   : in     Interfaces.C.unsigned;
      ppsaOut : access GNATCOM.Types.Pointer_To_SAFEARRAY)
     return GNATCOM.Types.HRESULT;
   pragma Import (StdCall, SafeArrayAllocDescriptor,
                    "SafeArrayAllocDescriptor");

   procedure SafeArrayDestroyDescriptor
     (psa      : access GNATCOM.Types.SAFEARRAY);
   pragma Import (StdCall, SafeArrayDestroyDescriptor,
                    "SafeArrayDestroyDescriptor");

   ----------
   -- Copy --
   ----------

   function Copy
     (From : access GNATCOM.Types.SAFEARRAY)
      return GNATCOM.Types.Pointer_To_SAFEARRAY
   is
      Temp : aliased GNATCOM.Types.Pointer_To_SAFEARRAY;
   begin
      Error_Check
        (SafeArrayCopy (From, Temp'Access));
      return Temp;
   end Copy;

   ------------
   -- Create --
   ------------

   function Create
     (VT          : GNATCOM.Types.VARTYPE;
      Lower_Bound : Integer;
      Elements    : Natural)
      return GNATCOM.Types.Pointer_To_SAFEARRAY
   is
      use type GNATCOM.Types.Pointer_To_SAFEARRAY;

      Temp : GNATCOM.Types.Pointer_To_SAFEARRAY;
   begin
      Temp := SafeArrayCreateVector (VT,
                                     Interfaces.C.long (Lower_Bound),
                                     Interfaces.C.unsigned (Elements));
      if Temp = null then
         raise ARRAY_CREATION_ERROR;
      end if;

      return Temp;
   end Create;

   ------------
   -- Create --
   ------------

   function Create
     (VT     : GNATCOM.Types.VARTYPE;
      Bounds : SafeArray_Bounds)
      return GNATCOM.Types.Pointer_To_SAFEARRAY
   is
      use type GNATCOM.Types.Pointer_To_SAFEARRAY;

      type Bound_Array is
        array (Bounds'Range) of GNATCOM.Types.SAFEARRAYBOUND;

      function SafeArrayCreate
        (vt        : in     Interfaces.C.unsigned_short;
         cDims     : in     Interfaces.C.unsigned;
         rgsabound : access Bound_Array)
        return GNATCOM.Types.Pointer_To_SAFEARRAY;
      pragma Import (StdCall, SafeArrayCreate, "SafeArrayCreate");

      Temp    : GNATCOM.Types.Pointer_To_SAFEARRAY;
      SABound : aliased Bound_Array;
   begin
      if Bounds'Length = 0 then
         raise ARRAY_CREATION_ERROR;
      end if;

      for N in Bounds'Range loop
         SABound (N).cElements :=
           Interfaces.C.unsigned_long (Bounds (N).Elements);
         SABound (N).lLbound :=
           Interfaces.C.long (Bounds (N).Lower_Bound);
      end loop;

      Temp := SafeArrayCreate (VT,
                               Bounds'Length,
                               SABound'Access);

      if Temp = null then
         raise ARRAY_CREATION_ERROR;
      end if;

      return Temp;
   end Create;

   ------------
   -- Create --
   ------------

   function Create
     (Lib_ID    : GNATCOM.Types.GUID;
      Ver_Maj   : Natural;
      Ver_Min   : Natural;
      Type_GUID : GNATCOM.Types.GUID;
      Bounds    : SafeArray_Bounds)
     return GNATCOM.Types.Pointer_To_SAFEARRAY
   is
      use GNATCOM.ITypeLib_Interface;
      use GNATCOM.ITypeInfo_Interface;

      Lib       : GNATCOM.ITypeLib_Interface.ITypeLib_Type;
      Type_Lib  : aliased GNATCOM.Types.Pointer_To_ITypeLib;
      Type_Info : GNATCOM.ITypeInfo_Interface.ITypeInfo_Type;
      GUID      : aliased GNATCOM.Types.GUID := Lib_ID;
      TGUID     : aliased GNATCOM.Types.GUID := Type_GUID;

      function LoadRegTypeLib
        (guid           : access GNATCOM.Types.GUID;
         wMaj           : Natural;
         wMin           : Natural;
         lcid           : Interfaces.C.long;
         pLib           : access GNATCOM.Types.Pointer_To_ITypeLib)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, LoadRegTypeLib, "LoadRegTypeLib");

   begin
      GNATCOM.Errors.Error_Check
        (LoadRegTypeLib
         (GUID'Access, Ver_Maj, Ver_Min, 0, Type_Lib'Access));

      Attach (Lib, Type_Lib);

      Attach (Type_Info, GetTypeInfoOfGuid (Lib, TGUID'Unchecked_Access));

      return Create (Pointer (Type_Info), Bounds);
   end Create;

   ------------
   -- Create --
   ------------

   function Create
     (Lib_ID      : GNATCOM.Types.GUID;
      Ver_Maj     : Natural;
      Ver_Min     : Natural;
      Type_GUID   : GNATCOM.Types.GUID;
      Lower_Bound : Integer;
      Elements    : Natural)
     return GNATCOM.Types.Pointer_To_SAFEARRAY
   is
   begin
      return Create (Lib_ID, Ver_Maj, Ver_Min, Type_GUID, (1 => (Lower_Bound,
                                                                 Elements)));
   end Create;

   ------------
   -- Create --
   ------------

   function Create
     (Lib_ID      : GNATCOM.Types.GUID;
      Ver_Maj     : Natural;
      Ver_Min     : Natural;
      Index       : Natural;
      Lower_Bound : Integer;
      Elements    : Natural)
     return GNATCOM.Types.Pointer_To_SAFEARRAY
   is
   begin
      return Create (Lib_ID, Ver_Maj, Ver_Min, Index, (1 => (Lower_Bound,
                                                             Elements)));
   end Create;

   ------------
   -- Create --
   ------------

   function Create
     (Lib_ID  : GNATCOM.Types.GUID;
      Ver_Maj : Natural;
      Ver_Min : Natural;
      Index   : Natural;
      Bounds  : SafeArray_Bounds)
     return GNATCOM.Types.Pointer_To_SAFEARRAY
   is
      use GNATCOM.ITypeLib_Interface;
      use GNATCOM.ITypeInfo_Interface;

      Lib       : GNATCOM.ITypeLib_Interface.ITypeLib_Type;
      Type_Lib  : aliased GNATCOM.Types.Pointer_To_ITypeLib;
      Type_Info : GNATCOM.ITypeInfo_Interface.ITypeInfo_Type;
      GUID      : aliased GNATCOM.Types.GUID := Lib_ID;

      function LoadRegTypeLib
        (guid           : access GNATCOM.Types.GUID;
         wMaj           : Natural;
         wMin           : Natural;
         lcid           : Interfaces.C.long;
         pLib           : access GNATCOM.Types.Pointer_To_ITypeLib)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, LoadRegTypeLib, "LoadRegTypeLib");

   begin
      GNATCOM.Errors.Error_Check
        (LoadRegTypeLib
         (GUID'Access, Ver_Maj, Ver_Min, 0, Type_Lib'Access));

      Attach (Lib, Type_Lib);

      Attach (Type_Info, GetTypeInfo (Lib, Interfaces.C.int (Index)));

      return Create (Pointer (Type_Info), Bounds);
   end Create;

   ------------
   -- Create --
   ------------

   function Create
     (Type_Info   : GNATCOM.Types.Pointer_To_ITypeInfo;
      Lower_Bound : Integer;
      Elements    : Natural)
     return GNATCOM.Types.Pointer_To_SAFEARRAY
   is
   begin
      return Create (Type_Info, (1 => (Lower_Bound, Elements)));
   end Create;

   ------------
   -- Create --
   ------------

   function Create
     (Type_Info : GNATCOM.Types.Pointer_To_ITypeInfo;
      Bounds    : SafeArray_Bounds)
     return GNATCOM.Types.Pointer_To_SAFEARRAY
   is
      function GetRecordInfoFromTypeInfo
        (Info          : in     GNATCOM.Types.Pointer_To_ITypeInfo;
         ppRecord_Info : access GNATCOM.Types.Pointer_To_Void)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, GetRecordInfoFromTypeInfo,
                       "GetRecordInfoFromTypeInfo");

      Record_Info : aliased GNATCOM.Types.Pointer_To_Void;

      use type GNATCOM.Types.Pointer_To_SAFEARRAY;

      type Bound_Array is
        array (Bounds'Range) of GNATCOM.Types.SAFEARRAYBOUND;

      function SafeArrayCreateEx
        (vt        : in     Interfaces.C.unsigned_short;
         cDims     : in     Interfaces.C.unsigned;
         rgsabound : access Bound_Array;
         pRecInfo  : in     GNATCOM.Types.Pointer_To_Void)
        return GNATCOM.Types.Pointer_To_SAFEARRAY;
      pragma Import (StdCall, SafeArrayCreateEx, "SafeArrayCreateEx");

      Temp    : GNATCOM.Types.Pointer_To_SAFEARRAY;
      SABound : aliased Bound_Array;
   begin
      GNATCOM.Errors.Error_Check
        (GetRecordInfoFromTypeInfo (Type_Info, Record_Info'Access));

      if Bounds'Length = 0 then
         raise ARRAY_CREATION_ERROR;
      end if;

      for N in Bounds'Range loop
         SABound (N).cElements :=
           Interfaces.C.unsigned_long (Bounds (N).Elements);
         SABound (N).lLbound :=
           Interfaces.C.long (Bounds (N).Lower_Bound);
      end loop;

      Temp := SafeArrayCreateEx (GNATCOM.Types.VT_RECORD,
                                 Bounds'Length,
                                 SABound'Access,
                                 Record_Info);

      if Temp = null then
         raise ARRAY_CREATION_ERROR;
      end if;

      return Temp;
   end Create;

   -------------------
   -- Create_Custom --
   -------------------

   function Create_Custom (Size_Of_Element : Positive;
                           Lower_Bound     : Integer;
                           Elements        : Natural)
                          return GNATCOM.Types.Pointer_To_SAFEARRAY
   is
   begin
      return Create_Custom (Size_Of_Element, (1 => (Lower_Bound, Elements)));
   end Create_Custom;

   -------------------
   -- Create_Custom --
   -------------------

   function Create_Custom (Size_Of_Element : Positive;
                           Bounds          : SafeArray_Bounds)
                          return GNATCOM.Types.Pointer_To_SAFEARRAY
   is
      use type GNATCOM.Types.HRESULT;
      use GNATCOM.Types;

      Result  : aliased GNATCOM.Types.Pointer_To_SAFEARRAY;

      type SA_Bounds_Type is
        array (Bounds'Range) of GNATCOM.Types.SAFEARRAYBOUND;

      type Pointer_To_SA_Bounds is access all SA_Bounds_Type;

      function To_Pointer_To_SA_Bounds is
         new Ada.Unchecked_Conversion (System.Address,
                                       Pointer_To_SA_Bounds);

      SABound : Pointer_To_SA_Bounds;
   begin
      if Bounds'Length = 0 then
         raise ARRAY_CREATION_ERROR;
      end if;

      if
        SafeArrayAllocDescriptor (Bounds'Length, Result'Access) /=
        GNATCOM.S_OK
      then
         raise ARRAY_CREATION_ERROR;
      end if;

      Result.cbElements := Interfaces.C.unsigned_long (Size_Of_Element);

      SABound := To_Pointer_To_SA_Bounds (Result.rgsabound'Address);

      for N in SABound.all'Range loop
         SABound (N).cElements :=
           Interfaces.C.unsigned_long (Bounds (N).Elements);
         SABound (N).lLbound :=
           Interfaces.C.long (Bounds (N).Lower_Bound);
      end loop;

      if SafeArrayAllocData (Result) /= GNATCOM.S_OK then
         SafeArrayDestroyDescriptor (Result);
         raise ARRAY_CREATION_ERROR;
      end if;

      return Result;
   end Create_Custom;

   ----------
   -- Free --
   ----------

   procedure Free (This : access GNATCOM.Types.SAFEARRAY) is
      use type Interfaces.C.unsigned_short;
      use type Interfaces.C.unsigned;

      FADF_VARIANT : constant := 16#0800#;
   begin
      if
        (Interfaces.C.unsigned (This.fFeatures) and FADF_VARIANT)
        =
        FADF_VARIANT
      then
         declare
            TempVar : GNATCOM.Types.VARIANT;
         begin
            --  By placing the SAFEARRAY first in to a VARIANT the
            --  contents of the SAFEARRAY of VARIANTS will be cleared

            GNATCOM.VARIANT.Initialize (TempVar);
            TempVar.vt := GNATCOM.Types.VT_ARRAY +
              GNATCOM.Types.VT_VARIANT;
            TempVar.u.parray := GNATCOM.Types.Pointer_To_SAFEARRAY (This);
            GNATCOM.VARIANT.Free (TempVar);
         end;
      else
         Error_Check
           (SafeArrayDestroy (This));
      end if;

--      Error_Check (SafeArrayDestroyData (This));
--      Error_Check (SafeArrayDestroy (This));
   exception
      when GNATCOM.VARIANT.ARRAY_LOCKED_ERROR =>
         raise ARRAY_LOCKED_ERROR;
   end Free;

   --------------------
   -- Get_Dimensions --
   --------------------

   function Get_Dimensions
     (Of_Array : access GNATCOM.Types.SAFEARRAY)
      return Positive
   is
   begin
      return Positive (SafeArrayGetDim (Of_Array));
   end Get_Dimensions;

   -----------------
   -- Get_Element --
   -----------------

   function Get_Element
     (Of_Array : access GNATCOM.Types.SAFEARRAY;
      Index    : in     Integer)
      return Element
   is
      type Index_Array is array (1 .. 1) of Interfaces.C.long;

      function SafeArrayGetElement
        (psa       : access GNATCOM.Types.SAFEARRAY;
         rgIndices : access Index_Array;
         pv        : access Element)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, SafeArrayGetElement, "SafeArrayGetElement");

      SAIndex   : aliased Index_Array;
      SAElement : aliased Element;
   begin
      SAIndex (1) := Interfaces.C.long (Index);
      Error_Check
        (SafeArrayGetElement (Of_Array,
                              SAIndex'Access,
                              SAElement'Access));
      return SAElement;
   end Get_Element;

   ---------------------
   -- Get_Lower_Bound --
   ---------------------

   function Get_Lower_Bound
     (Of_Array  : access GNATCOM.Types.SAFEARRAY;
      Dimension : in     Positive                := 1)
      return Integer
   is
      LBound : aliased Interfaces.C.long;
   begin
      Error_Check
        (SafeArrayGetLBound (Of_Array,
                             Interfaces.C.unsigned (Dimension),
                             LBound'Access));

      return Integer (LBound);
   end Get_Lower_Bound;

   ---------------------
   -- Get_Upper_Bound --
   ---------------------

   function Get_Upper_Bound
     (Of_Array  : access GNATCOM.Types.SAFEARRAY;
      Dimension : in     Positive                := 1)
      return Integer
   is
      UBound : aliased Interfaces.C.long;
   begin
      Error_Check
        (SafeArrayGetUBound (Of_Array,
                             Interfaces.C.unsigned (Dimension),
                             UBound'Access));

      return Integer (UBound);
   end Get_Upper_Bound;

   ---------------
   -- Get_Value --
   ---------------

   function Get_Value
     (Of_Array : access GNATCOM.Types.SAFEARRAY;
      Index    : in     Index_Array)
      return Element
   is
      type Index_Array is array (Index'Range) of Interfaces.C.long;

      function SafeArrayGetElement
        (psa       : access GNATCOM.Types.SAFEARRAY;
         rgIndices : access Index_Array;
         pv        : access Element)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, SafeArrayGetElement, "SafeArrayGetElement");

      SAIndex   : aliased Index_Array;
      SAElement : aliased Element;
   begin
      for N in Index'Range loop
         SAIndex (N) := Interfaces.C.long (Index (N));
      end loop;

      Error_Check
        (SafeArrayGetElement (Of_Array,
                              SAIndex'Access,
                              SAElement'Access));
      return SAElement;
   end Get_Value;

   -----------------
   -- Put_Element --
   -----------------

   procedure Put_Element
     (Of_Array : access GNATCOM.Types.SAFEARRAY;
      Index    : in     Integer;
      Value    : in     Element)
   is
      type Index_Array is array (1 .. 1) of Interfaces.C.long;

      function SafeArrayPutElement
        (psa       : access GNATCOM.Types.SAFEARRAY;
         rgIndices : access Index_Array;
         pv        : access Element)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, SafeArrayPutElement, "SafeArrayPutElement");

      SAIndex   : aliased Index_Array;
      SAElement : aliased Element := Value;
   begin
      SAIndex (1) := Interfaces.C.long (Index);
      Error_Check
        (SafeArrayPutElement (Of_Array,
                              SAIndex'Access,
                              SAElement'Access));
   end Put_Element;

   ---------------
   -- Put_Value --
   ---------------

   procedure Put_Value
     (Of_Array : access GNATCOM.Types.SAFEARRAY;
      Index    : in     Index_Array;
      Value    : in     Element)
   is
      type Index_Array is array (Index'Range) of Interfaces.C.long;

      function SafeArrayPutElement
        (psa       : access GNATCOM.Types.SAFEARRAY;
         rgIndices : access Index_Array;
         pv        : access Element)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, SafeArrayPutElement, "SafeArrayPutElement");

      SAIndex   : aliased Index_Array;
      SAElement : aliased Element := Value;
   begin
      for N in Index'Range loop
         SAIndex (N) := Interfaces.C.long (Index (N));
      end loop;

      Error_Check
        (SafeArrayPutElement (Of_Array,
                              SAIndex'Access,
                              SAElement'Access));
   end Put_Value;

   ------------------
   -- Put_IUnknown --
   ------------------

   procedure Put_IUnknown
     (Of_Array : access GNATCOM.Types.SAFEARRAY;
      Index    : in     Integer;
      Value    : in     GNATCOM.Types.Pointer_To_IUnknown)
   is
      type Index_Array is array (1 .. 1) of Interfaces.C.long;

      function SafeArrayPutElement
        (psa       : access GNATCOM.Types.SAFEARRAY;
         rgIndices : access Index_Array;
         pv        : in     GNATCOM.Types.Pointer_To_IUnknown)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, SafeArrayPutElement, "SafeArrayPutElement");

      SAIndex   : aliased Index_Array;
   begin
      SAIndex (1) := Interfaces.C.long (Index);

      Error_Check
        (SafeArrayPutElement (Of_Array,
                              SAIndex'Access,
                              Value));
   end Put_IUnknown;

   ------------------
   -- Put_IUnknown --
   ------------------

   procedure Put_IUnknown
     (Of_Array : access GNATCOM.Types.SAFEARRAY;
      Index    : in     Index_Array;
      Value    : in     GNATCOM.Types.Pointer_To_IUnknown)
   is
      type Index_Array is array (Index'Range) of Interfaces.C.long;

      function SafeArrayPutElement
        (psa       : access GNATCOM.Types.SAFEARRAY;
         rgIndices : access Index_Array;
         pv        : GNATCOM.Types.Pointer_To_IUnknown)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, SafeArrayPutElement, "SafeArrayPutElement");

      SAIndex   : aliased Index_Array;
   begin
      for N in Index'Range loop
         SAIndex (N) := Interfaces.C.long (Index (N));
      end loop;

      Error_Check
        (SafeArrayPutElement (Of_Array,
                              SAIndex'Access,
                              Value));
   end Put_IUnknown;

   -------------------
   -- Put_IDispatch --
   -------------------

   procedure Put_IDispatch
     (Of_Array : access GNATCOM.Types.SAFEARRAY;
      Index    : in     Integer;
      Value    : in     GNATCOM.Types.Pointer_To_IDispatch)
   is
      type Index_Array is array (1 .. 1) of Interfaces.C.long;

      function SafeArrayPutElement
        (psa       : access GNATCOM.Types.SAFEARRAY;
         rgIndices : access Index_Array;
         pv        : in     GNATCOM.Types.Pointer_To_IDispatch)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, SafeArrayPutElement, "SafeArrayPutElement");

      SAIndex   : aliased Index_Array;
   begin
      SAIndex (1) := Interfaces.C.long (Index);

      Error_Check
        (SafeArrayPutElement (Of_Array,
                              SAIndex'Access,
                              Value));
   end Put_IDispatch;

   -------------------
   -- Put_IDispatch --
   -------------------

   procedure Put_IDispatch
     (Of_Array : access GNATCOM.Types.SAFEARRAY;
      Index    : in     Index_Array;
      Value    : in     GNATCOM.Types.Pointer_To_IDispatch)
   is
      type Index_Array is array (Index'Range) of Interfaces.C.long;

      function SafeArrayPutElement
        (psa       : access GNATCOM.Types.SAFEARRAY;
         rgIndices : access Index_Array;
         pv        : GNATCOM.Types.Pointer_To_IDispatch)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, SafeArrayPutElement, "SafeArrayPutElement");

      SAIndex   : aliased Index_Array;
   begin
      for N in Index'Range loop
         SAIndex (N) := Interfaces.C.long (Index (N));
      end loop;

      Error_Check
        (SafeArrayPutElement (Of_Array,
                              SAIndex'Access,
                              Value));
   end Put_IDispatch;

   --------------
   -- Put_BSTR --
   --------------

   procedure Put_BSTR
     (Of_Array : access GNATCOM.Types.SAFEARRAY;
      Index    : in     Integer;
      Value    : in     GNATCOM.Types.BSTR;
      Clear    : in     Boolean                 := True)
   is
      type Index_Array is array (1 .. 1) of Interfaces.C.long;

      function SafeArrayPutElement
        (psa       : access GNATCOM.Types.SAFEARRAY;
         rgIndices : access Index_Array;
         pv        : in     GNATCOM.Types.BSTR)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, SafeArrayPutElement, "SafeArrayPutElement");

      SAIndex   : aliased Index_Array;
   begin
      SAIndex (1) := Interfaces.C.long (Index);

      Error_Check
        (SafeArrayPutElement (Of_Array,
                              SAIndex'Access,
                              Value));

      if Clear then
         GNATCOM.BSTR.Free (Value);
      end if;
   end Put_BSTR;

   --------------
   -- Put_BSTR --
   --------------

   procedure Put_BSTR
     (Of_Array : access GNATCOM.Types.SAFEARRAY;
      Index    : in     Index_Array;
      Value    : in     GNATCOM.Types.BSTR;
      Clear    : in     Boolean                 := True)
   is
      type Index_Array is array (Index'Range) of Interfaces.C.long;

      function SafeArrayPutElement
        (psa       : access GNATCOM.Types.SAFEARRAY;
         rgIndices : access Index_Array;
         pv        : in     GNATCOM.Types.BSTR)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, SafeArrayPutElement, "SafeArrayPutElement");

      SAIndex   : aliased Index_Array;
   begin
      for N in Index'Range loop
         SAIndex (N) := Interfaces.C.long (Index (N));
      end loop;

      Error_Check
        (SafeArrayPutElement (Of_Array,
                              SAIndex'Access,
                              Value));

      if Clear then
         GNATCOM.BSTR.Free (Value);
      end if;
   end Put_BSTR;

   -----------------
   -- Put_VARIANT --
   -----------------

   procedure Put_VARIANT
     (Of_Array : access GNATCOM.Types.SAFEARRAY;
      Index    : in     Integer;
      Value    : in     GNATCOM.Types.VARIANT;
      Clear    : in     Boolean                 := True)
   is
      type Index_Array is array (1 .. 1) of Interfaces.C.long;

      function SafeArrayPutElement
        (psa       : access GNATCOM.Types.SAFEARRAY;
         rgIndices : access Index_Array;
         pv        : access GNATCOM.Types.VARIANT)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, SafeArrayPutElement, "SafeArrayPutElement");

      SAIndex   : aliased Index_Array;
      SAElement : aliased GNATCOM.Types.VARIANT := Value;
   begin
      SAIndex (1) := Interfaces.C.long (Index);

      Error_Check
        (SafeArrayPutElement (Of_Array,
                              SAIndex'Access,
                              SAElement'Access));

      if Clear then
         GNATCOM.VARIANT.Free (Value);
      end if;
   end Put_VARIANT;

   -----------------
   -- Put_VARIANT --
   -----------------

   procedure Put_VARIANT
     (Of_Array : access GNATCOM.Types.SAFEARRAY;
      Index    : in     Index_Array;
      Value    : in     GNATCOM.Types.VARIANT;
      Clear    : in     Boolean                 := True)
   is
      type Index_Array is array (Index'Range) of Interfaces.C.long;

      function SafeArrayPutElement
        (psa       : access GNATCOM.Types.SAFEARRAY;
         rgIndices : access Index_Array;
         pv        : access GNATCOM.Types.VARIANT)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, SafeArrayPutElement, "SafeArrayPutElement");

      SAIndex   : aliased Index_Array;
      SAElement : aliased GNATCOM.Types.VARIANT := Value;
   begin
      for N in Index'Range loop
         SAIndex (N) := Interfaces.C.long (Index (N));
      end loop;

      Error_Check
        (SafeArrayPutElement (Of_Array,
                              SAIndex'Access,
                              SAElement'Access));

      if Clear then
         GNATCOM.VARIANT.Free (Value);
      end if;
   end Put_VARIANT;

   -----------------
   -- Error_Check --
   -----------------

   procedure Error_Check (Result : in GNATCOM.Types.HRESULT) is
   begin
      GNATCOM.Errors.Set_Last_HRESULT (Result);

      if GNATCOM.Errors.FAILED (Result) then
         case Result is
            when DISP_E_ARRAYISLOCKED =>
               raise ARRAY_LOCKED_ERROR;
            when DISP_E_BADINDEX =>
               raise INVALID_INDEX_ERROR;
            when others =>
               GNATCOM.Errors.Error_Check (Result);
         end case;
      end if;
   end Error_Check;

end GNATCOM.SafeArray;