;;; CLisp OLE Automation interface
;;;
;;; Copyright (C) 2005 Tomas Hlavaty <kvietaag@seznam.cz>
;;;
;;; This is Free Software, covered by the GNU GPL (v2)
;;; See http://www.gnu.org/copyleft/gpl.html

(defpackage "OLE"
  (:use "LISP" "FFI")
  (:export "INIT" "DONE" "CREATE" "RELEASE"
		   "INVOKE" "INVOKE-GET" "INVOKE-PUT" "INVOKE-METHOD"
		   "WITH-OLE" "WITH-IUNKNOWN" "IUNKNOWN" "IDISPATCH"))

(in-package "OLE")

(pushnew :ole *features*)

(default-foreign-language :stdc)

(c-lines "
#include <windows.h>
#include <ole2.h>
")

;;; win32api constants are loaded from c header files

(defconstant +cfiles+ "c:/cygwin/usr/include/w32api/*.h") ; update this!

(defun load-win32api-constants (cfiles)
  (let ((n 0))
	(dolist (filename (directory cfiles) n)
	  (flet ((match (line regexp &optional hex)
			   (multiple-value-bind (all key value)
				   (regexp:match regexp line :extended t :ignore-case t)
				 (when all
				   (let ((sym (read-from-string
							   (regexp:match-string line key))))
					 (eval
					  `(defconstant ,sym
						,(read-from-string
						  (concatenate 'string
									   (if hex "#x" "")
									   (regexp:match-string line value)))))
					 (incf n))))))
		(with-open-file (in filename)
		  (loop for line = (read-line in nil nil)
				while line
				do (or (match line "^#define ([a-zA-Z0-9_]+) ([0-9]+)$")
					   (match line "#define ([a-zA-Z0-9_]+) \\((-[0-9]+)\\)$")
					   (match line "^#define ([a-zA-Z0-9_]+) 0x([0-9]+)$" t))))))))

;;(load-win32api-constants +cfiles+))

;;; types

(defconstant +wencoding+ charset:unicode-16-little-endian) ; used by OLE

(defconstant CP_ACP 0)
(defconstant LOCALE_USER_DEFAULT 1024)
(defconstant LOCALE_SYSTEM_DEFAULT 2048)
(defconstant DISPATCH_METHOD 1)
(defconstant DISPATCH_PROPERTYGET 2)
(defconstant DISPATCH_PROPERTYPUT 4)
(defconstant DISPID_PROPERTYPUT -3)

(def-c-type HRESULT ulong)
(def-c-type WORD ushort)
(def-c-type DWORD ulong)
(def-c-type PVOID (c-ptr-null nil))
(def-c-type BSTR c-pointer)
(def-c-type DISPID long)
(def-c-type LCID DWORD)

(def-c-enum VARTYPE
	(VT_EMPTY 0) VT_NULL VT_I2 VT_I4 VT_R4 VT_R8 VT_CY VT_DATE VT_BSTR
	VT_DISPATCH VT_ERROR VT_BOOL VT_VARIANT VT_UNKNOWN VT_DECIMAL
	(VT_I1 16) VT_UI1 VT_UI2 VT_UI4 VT_I8 VT_UI8 VT_INT VT_UINT VT_VOID
	VT_HRESULT VT_PTR VT_SAFEARRAY VT_CARRAY VT_USERDEFINED VT_LPSTR
	VT_LPWSTR (VT_RECORD 36) (VT_INT_PTR 37) (VT_UINT_PTR 38) (VT_FILETIME 64)
	VT_BLOB VT_STREAM VT_STORAGE VT_STREAMED_OBJECT VT_STORED_OBJECT
	VT_BLOB_OBJECT VT_CF VT_CLSID (VT_BSTR_BLOB #xfff) (VT_VECTOR #x1000)
	(VT_ARRAY #x2000) (VT_BYREF #x4000) (VT_RESERVED #x8000)
	(VT_ILLEGAL #xffff) (VT_ILLEGALMASKED #xfff) (VT_TYPEMASK #xfff))

(def-c-struct SAFEARRAYBOUND
  (cElements ULONG)
  (lLbound LONG))

(def-c-struct SAFEARRAY
  (cDims USHORT)
  (fFeatures USHORT)
  (cbElements ULONG)
  (cLocks ULONG)
  (pvData PVOID)
  (rgsabound (c-array SAFEARRAYBOUND 1))) ; what about following bounds?

;;(sizeof 'SAFEARRAY)

;; (def-c-struct VARIANT
;;   (vt ushort) ;VARTYPE)
;;   (wReserved1 WORD)
;;   (wReserved2 WORD)
;;   (wReserved3 WORD)
;;   (val (c-union
;; 		(bstrVal BSTR)
;; 		(pdispVal c-pointer) ;(pdispVal LPDISPATCH)
;; 		(parray (c-ptr SAFEARRAY))
;; 		(dblVal double-float)))) ; to get the right size only

(def-c-type VARIANT (c-array uint8 16)) ; must be equal to (%variant-size)

;;(sizeof 'VARIANT)

(def-c-struct GUID
  (data1 ulong)
  (data2 ushort)
  (data3 ushort)
  (data4 (c-array uchar 8)))

(def-c-var IID_NULL (:type GUID) (:name "IID_NULL") (:read-only t))
(def-c-var IID_IDispatch (:type GUID) (:name "IID_IDispatch") (:read-only t))

(def-c-enum CLSCTX
	(CLSCTX_INPROC_SERVER 1) (CLSCTX_INPROC_HANDLER 2) (CLSCTX_LOCAL_SERVER 4)
	(CLSCTX_INPROC_SERVER16 8) (CLSCTX_REMOTE_SERVER 16))

(def-c-struct DISPPARAMS
  (rgvarg (c-array-ptr VARIANT))
  (rgdispidNamedArgs (c-array-ptr DISPID))
  (cArgs UINT)
  (cNamedArgs UINT))

;;; (de)initialisation

(def-call-out %CoInitialize (:name "CoInitialize")
  (:arguments (reserved c-pointer)) (:return-type HRESULT))

(def-call-out %CoUninitialize (:name "CoUninitialize"))

(defun init ()
  (%CoInitialize nil))

(defun done ()
  (%CoUninitialize))

(defparameter *ole-objects* nil)

(defmacro with-ole (vars &body body)
  `(let ((*ole-objects* (make-hash-table :key-type 'foreign-address
										 :value-type 'iunknown)))
	(ole:init)
	(unwind-protect (let* ,vars ,@body)
	  (maphash #'(lambda (key val)
				   (declare (ignore key))
				   (ole%Release val))
			   *ole-objects*)
	  (clrhash *ole-objects*)
	  (ole:done))))

;;; objects

(def-call-out %CLSIDFromProgID (:name "CLSIDFromProgID")
  (:arguments (wprogid c-pointer) (clsid (c-ptr GUID) :out :alloca))
  (:return-type HRESULT))

(def-call-out %CoCreateInstance (:name "CoCreateInstance")
  (:arguments (clsid (c-ptr GUID)) (unknown c-pointer) (context DWORD)
			  (iid c-pointer) (dispatch c-pointer))
  (:return-type HRESULT))

(defmacro with-wstring ((wstr str) &body body)
  `(with-foreign-string (,wstr elems bytes ,str :encoding +wencoding+)
	(declare (ignore elems bytes))
	,@body))

(defun create (progid &optional raw)
  (with-wstring (wprogid progid)
	(multiple-value-bind (result clsid)
		(%CLSIDFromProgID wprogid)
	  (with-c-var (dispatch 'c-pointer)
		(let ((result (%CoCreateInstance clsid nil CLSCTX_LOCAL_SERVER
										 (c-var-address IID_IDispatch)
										 (c-var-address dispatch))))
		  (when (= 0 result) ; ok
			(if raw
				dispatch
				(make-instance 'IDispatch :interface dispatch))))))))

(defmacro with-c-pointer ((var ptr type) &body body)
  (let ((pvar (gensym)))
	`(with-c-var (,pvar 'c-pointer)
	  (setf ,pvar ,ptr)
	  (let ((,var (cast ,pvar ,type)))
		,@body))))

(defmacro def-ole-method (name (this type) niface iface-size nfn vtable-size
						  &key arguments return-type)
  `(defmethod ,(intern (concatenate 'string "OLE%" (symbol-name name)) "OLE")
	,(append (list (list this type))
			 (loop for arg in arguments
				   when (not (eq :out (third arg)))
				   collect (first arg)))
	;; with interface
	(with-c-pointer (iface (interface ,this)
					 '(c-ptr (c-array-max c-pointer ,iface-size)))
	  ;; with vtable
	  (with-c-pointer (vtable (aref iface ,niface)
							  '(c-ptr (c-array-max c-pointer ,vtable-size)))
		;; with method
		(with-c-pointer (fn (aref vtable ,nfn)
							'(c-function ,(append
										   '(:arguments (interface c-pointer))
										   arguments)
							  (:return-type ,return-type)))
		  ;; call the method
		  (funcall fn (interface ,this)
				   ,@(loop for arg in arguments
						   when (not (eq :out (third arg)))
						   collect (first arg))))))))

;;; IUnknown

;;; Q: are we always calling the right "virtual" method?

(defclass IUnknown ()
  ((interface :type 'foreign-address :initarg :interface :accessor interface))
  (:documentation "OLE IUnknown interface."))

(defmethod initialize-instance :after ((self IUnknown) &rest args)
  (declare (ignore args))
  (let ((iface (interface self)))
	(if iface ;; what about duplicate objects with same iface?
		(setf (gethash iface *ole-objects*) self)
		(error "IUnknown interface pointer cannot be null!" self))))

(def-ole-method QueryInterface (this IUnknown) 0 1 0 3
				:arguments ((iid (c-ptr GUID)) (object c-pointer)) ; why c-pointer only?
				:return-type HRESULT)
;;(def-ole-method QueryInterface (this IUnknown) 0 1 0 3
;;				:arguments ((iid (c-ptr GUID)) (object (c-ptr c-pointer)))
;;				:return-type HRESULT)
(def-ole-method AddRef         (this IUnknown) 0 1 1 3 :return-type ulong)
(def-ole-method Release        (this IUnknown) 0 1 2 3 :return-type ulong)

(defmacro with-iunknown ((var cmd) &body body)
  `(let ((,var ,cmd))
	(unwind-protect (progn ,@body)
	  (ole%Release ,var))))

;;(with-iunknown (a (create "excel.application")) t)

;;; too complicated usage QueryInterface, handle arg conversion in def-ole-method?
;; (with-iunknown (a (create "excel.application"))
;;   (with-c-var (p 'c-pointer)
;; 	(let ((result (QueryInterface a IID_IDispatch (c-var-address p)))) ; addref automatically!
;; 	  (format t "QueryInterface ~a ~a" result p)
;; 	  (when (= 0 result) ; ok but I have p=nil:-(
;; 		(let ((o (make-instance 'IDispatch :interface p)))
;; 		  (Release o)
;; 		  o)))))

;;; IDispatch

(defclass IDispatch (IUnknown)
  ()
  (:documentation "OLE IDispatch interface."))

;;(def-ole-method GetTypeInfoCount (this IDispatch) 0 1 3 7 :arguments ((count (c-ptr uint))) :return-type HRESULT)
;;(def-ole-method GetTypeInfo      (this IDispatch) 0 1 4 7 :arguments ((type uint) ()):return-type ulong)

(def-ole-method GetIDsOfNames
	(this IDispatch) 0 1 5 7
	:arguments ((iid (c-ptr GUID)) (pwname c-pointer) (n uint) (locale LCID)
				(id (c-ptr DISPID) :out :alloca))
	:return-type HRESULT)

(def-ole-method Invoke
	(this IDispatch) 0 1 6 7
	:arguments ((id DISPID) (iid (c-ptr GUID)) (locale LCID)
				(type WORD) (dp (c-ptr DISPPARAMS))
				(result (c-ptr VARIANT) :out :alloca)
				(excepinfo c-pointer) (nn c-pointer))
	:return-type HRESULT)

;;(init)
;;(setq a (make-instance 'IDispatch :interface nil))
;;(setq a (create "excel.application"))
;;(QueryInterface a)
;;(interface a)

;;; variants

(def-call-out %VariantClear (:name "VariantClear")
  (:arguments (this (c-ptr VARIANT) :in-out)))

(def-call-out %VariantCopy (:name "VariantCopy")
  (:arguments (out (c-ptr VARIANT) :out :alloca)
			  (in (c-ptr VARIANT))))

(def-call-out %VariantChangeType1 (:name "VariantChangeType")
  (:arguments (out (c-ptr VARIANT) :out :alloca)
			  (in (c-ptr VARIANT))
 			  (n ushort) ; have to be 1!
			  (type VARTYPE)))

(def-call-out %SysAllocString (:name "SysAllocString")
  (:arguments (bstr BSTR)) (:return-type c-pointer))

(def-call-out %SysFreeString (:name "SysFreeString")
  (:arguments (bstr BSTR)))

(def-call-out %SysStringLen (:name "SysStringLen")
  (:arguments (bstr BSTR)) (:return-type uint))

(def-call-out %WideCharToMultiByte (:name "WideCharToMultiByte")
  (:arguments (cp uint) (x DWORD) (bstr BSTR) (nbstr int)
			  (str c-pointer) (nstr int) (cstr c-pointer) (pbool c-pointer))
  (:return-type int))
;;(UINT,DWORD,LPCWSTR,int,LPSTR,int,LPCSTR,LPBOOL); 

(defun bstr2lisp (bstr)
  (let ((n (%SysStringLen bstr)))
	(with-c-var (str `(c-array char ,n))
	  (%WideCharToMultiByte CP_ACP 0 bstr -1 (c-var-address str) n nil nil)
	  (ext:convert-string-from-bytes str custom:*default-file-encoding*))))

(defmacro with-variant ((v a) &body body)
  `(with-c-var (,v 'VARIANT)
	(let ((,a (c-var-address ,v)))
	  ,@body)))

(c-lines "
void variant_set_string (VARIANT *this, BSTR value)
{
  this->vt = VT_BSTR;
  this->bstrVal = value;
}

void variant_set_dispatch (VARIANT *this, IDispatch *value)
{
  this->vt = VT_DISPATCH;
  this->pdispVal = value;
}

void variant_set_safearray (VARIANT *this, SAFEARRAY *value)
{
  this->vt = VT_ARRAY | VT_VARIANT; //VT_SAFEARRAY;
  this->parray = value;
}

BSTR variant_get_string (VARIANT *this)
{
  return this->bstrVal;
}

IDispatch *variant_get_dispatch (VARIANT *this)
{
  return this->pdispVal;
}

SAFEARRAY *variant_get_safearray (VARIANT *this)
{
  return this->parray;
}

int variant_size (void)
{
  return sizeof (VARIANT);
}

int variant_type (VARIANT *this)
{
  return this->vt;
}
")

(def-call-out %variant-set-string (:name "variant_set_string")
  (:arguments (this (c-ptr VARIANT) :in-out) (bstr BSTR)))

(def-call-out %variant-set-dispatch (:name "variant_set_dispatch")
  (:arguments (this (c-ptr VARIANT) :in-out) (dispatch c-pointer)))

(def-call-out %variant-set-safearray (:name "variant_set_safearray")
  (:arguments (this (c-ptr VARIANT) :in-out) (safearray c-pointer)))

(def-call-out %variant-get-string (:name "variant_get_string")
  (:arguments (this (c-ptr VARIANT))) (:return-type BSTR))

(def-call-out %variant-get-dispatch (:name "variant_get_dispatch")
  (:arguments (this (c-ptr VARIANT))) (:return-type c-pointer))

(def-call-out %variant-get-safearray (:name "variant_get_safearray")
  (:arguments (this (c-ptr VARIANT))) (:return-type c-pointer))

(def-call-out %variant-size (:name "variant_size")
  (:return-type int))

(def-call-out %variant-type (:name "variant_type")
  (:arguments (this (c-ptr VARIANT))) (:return-type int))

(defun make-variant ()
  (make-array (%variant-size)
			  :element-type '(unsigned-byte 8) :initial-element 0))

;;(%variant-type (%variant-set-string (make-variant) nil))

(defun variant-string (val)
  (with-wstring (wstr val)
	(%variant-set-string (make-variant) (%SysAllocString wstr))))

;;(%variant-type (variant-string "1"))

(defun variant-dispatch (val)
  (%variant-set-dispatch (make-variant) (interface val)))

(defun variant-safearray (val)
  (%variant-set-safearray (make-variant) (safearray-from-lisp val)))

(defun variant-convert (var vt)
  (%VariantChangeType1 var 1 vt))

;;(variant-convert (variant-string "1") VT_R8)
;;(variant-convert (variant-string "1.23") VT_R8)

(defun variant-number (val)
  (variant-convert (variant-string (format nil "~a" val)) VT_R8))

;;(variant-number 1)
;;(variant-number 1.23)
;;(variant-convert (variant-string "1") VT_R8)
;;(variant-convert (variant-number 1) VT_BSTR)
;;(bstr2lisp (%variant-get-string (variant-convert (variant-number 1) VT_BSTR)))
;;(bstr2lisp (%variant-get-string (variant-convert (variant-number 1.23) VT_BSTR)))
;;(bstr2lisp (%variant-get-string (variant-convert (variant-number 3.141592653589) VT_BSTR)))

(defun variant-new (val)
  (ctypecase val
	(real (variant-number val))
	(string (variant-string val))
	(idispatch (variant-dispatch val))
	(array (variant-safearray val))))

;;(variant-new 1)
;;(variant-new 1.23)
;;(variant-new 3.141592653589)
;;(variant-new "hello")

(defun variant-get (var &optional raw)
  (ecase (enum-from-value 'VARTYPE (%variant-type var))
	(VT_EMPTY (values-list nil))
	(VT_NULL nil)
	(VT_BSTR (bstr2lisp (%variant-get-string var)))
	(VT_DISPATCH
	 (let ((dispatch (%variant-get-dispatch var)))
	   (if raw
		   dispatch
		   (make-instance 'IDispatch :interface dispatch))))
	((VT_DATE VT_CY) ; convert to string
	 (variant-get (variant-convert var VT_BSTR)))
	(VT_BOOL ; read from string and convert to nil|t
	 (let ((tmp (variant-convert var VT_BSTR)))
	   (values (if (= 0 (read-from-string (bstr2lisp (%variant-get-string tmp))))
				   nil t))))
	((VT_I2 VT_I4 VT_R4 VT_R8 VT_DECIMAL VT_I1 VT_UI1 VT_UI2 VT_UI4
			VT_I8 VT_UI8 VT_INT VT_UINT) ; read from string
	 (let ((tmp (variant-convert var VT_BSTR)))
	   (values (read-from-string (bstr2lisp (%variant-get-string tmp))))))
	(VT_SAFEARRAY (safearray-to-lisp (%variant-get-safearray var) raw))))

;;(variant-get (variant-new 1))
;;(variant-get (variant-new 1.23))
;;(variant-get (variant-new 3.141592653589))
;;(variant-get (variant-new "hello"))
;;(variant-get (variant-new #2A((1 2) ("a" "b"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(deftype variant () '(array (unsigned-byte 8) 16))
;;(make-array 2 :element-type 'VARIANT)

(defun invoke (this type name args &optional raw)
  (let* ((n (length args))
		 (params (make-array n :element-type 'VARIANT)))
	;; set up params
	(loop for arg in args
		  for i from 0
		  do (setf (aref params i) (variant-new arg)))
	;; get DISPID for name passed
	(with-wstring (wname name)
	  (with-c-var (wname2 'c-pointer)
		(setf wname2 wname)
		(multiple-value-bind (hresult id)
			(ole%GetIDsOfNames this IID_NULL (c-var-address wname2) 1 LOCALE_USER_DEFAULT)
		  ;; call invoke
		  (let ((dp (make-DISPPARAMS :cArgs n :rgvarg params
									 :cNamedArgs 0 :rgdispidNamedArgs nil)))
			;; handle special-case for property-puts!
			(when (not (zerop (logand type DISPATCH_PROPERTYPUT)))
			  (setf (DISPPARAMS-cNamedArgs dp) 1)
			  (setf (DISPPARAMS-rgdispidNamedArgs dp)
					(make-array 1 :initial-element DISPID_PROPERTYPUT)))
			(multiple-value-bind (hresult result)
				(ole%Invoke this id IID_NULL LOCALE_SYSTEM_DEFAULT type dp nil nil)
			  ;; convert result to lisp
			  (variant-get result raw))))))))

(defun invoke-get (this name &rest args)
  (invoke this DISPATCH_PROPERTYGET name args))

(defun invoke-put (this name &rest args)
  (invoke this DISPATCH_PROPERTYPUT name args))

(defun invoke-method (this name &rest args)
  (invoke this DISPATCH_METHOD name args))

;;(with-ole ()
;;  (with-iunknown (excel (create "excel.application"))
;;	(invoke-put excel "visible" 1)))

;;; SafeArray support
;;;
;;; A SafeArray is represented by c-pointer as it is created and
;;; destroyed outside lisp.

(def-call-out %SafeArrayCreate (:name "SafeArrayCreate")
  (:arguments (type VARTYPE) (ndim uint)
			  (bounds (c-array-ptr SAFEARRAYBOUND)))
  (:return-type c-pointer))

(def-call-out %SafeArrayPutElement (:name "SafeArrayPutElement")
  (:arguments (safearray c-pointer) (subscripts (c-array-ptr long))
			  (value (c-ptr VARIANT))))

(def-call-out %SafeArrayGetElement (:name "SafeArrayGetElement")
  (:arguments (safearray c-pointer) (subscripts (c-array-ptr long))
			  (value (c-ptr VARIANT) :out :alloca)))

(def-call-out %SafeArrayDestroy (:name "SafeArrayDestroy")
  (:arguments (safearray c-pointer)))

(def-call-out %SafeArrayGetDim (:name "SafeArrayGetDim")
  (:arguments (safearray c-pointer)) (:return-type uint))

(def-call-out %SafeArrayGetLBound (:name "SafeArrayGetLBound")
  (:arguments (safearray c-pointer) (dim uint)
			  (lbounds (c-ptr long) :out :alloca)))

(def-call-out %SafeArrayGetUBound (:name "SafeArrayGetUBound")
  (:arguments (safearray c-pointer) (dim uint)
			  (ubound (c-ptr long) :out :alloca)))

(defun safearray-create (dimensions)
  (let* ((rank (length dimensions))
		 (bounds (make-array rank :element-type 'SAFEARRAYBOUND)))
	(loop for n in dimensions
		  for i from 0
		  do (setf (aref bounds i) (make-SAFEARRAYBOUND :celements n :llbound 0)))
	(%SafeArrayCreate VT_VARIANT rank bounds)))

(defmacro with-safearray (safearray &body body)
  `(unwind-protect (progn ,@body)
	(%SafeArrayDestroy ,safearray)))

;;; Unfortunatelly, I can't use ROW-MAJOR_AREF for iteration through
;;; array elements because anything like that doesn't exist in winapi
;;; and I can't restore subscripts from index.
;;;
;;;   (let ((a (make-array '(1 2 3))))
;;;     (dotimes (i (array-total-size a) a)
;;; 	  (setf (row-major-aref a i) i)))

(defun for-all-elements (dims fn)
  "Call FN for all elements of an array with dimensions DIMS."
  (let* ((rank (length dims))
		 (mods (make-array rank :element-type 'integer)))
	;; set up mods
	(dotimes (i rank)
	  (setf (aref mods i)
			(if (= 0 i)
				1
				(* (aref mods (1- i))
				   (nth (1- i) dims)))))
	;; enumerate endices
	(dotimes (i (reduce #'* dims)) ; for each element of array
	  (let ((subscripts nil))
		(dotimes (j rank) ; for each dimension
		  (push (mod (truncate i (aref mods j))
					 (nth j dims))
				subscripts))
		(funcall fn (nreverse subscripts))))))

;;(for-all-elements '(2 3) (lambda (subscripts) (format t "~s~%" subscripts)))

(defun safearray-from-lisp (array)
  "Convert lisp ARRAY to SAFEARRAY."
  (let ((safearray (safearray-create (array-dimensions array))))
	(for-all-elements
	 (array-dimensions array)
	 (lambda (subscripts)
	   (let ((variant (variant-new (apply #'aref array subscripts)))
			 (subs (make-array (array-rank array) :initial-contents subscripts)))
		 (%SafeArrayPutElement safearray subs variant))))
	safearray))

(defun safearray-dimensions (safearray)
  (let ((dims nil)
		(rank (%SafeArrayGetDim safearray)))
	(dotimes (i rank (nreverse dims))
	  (let ((lbound (%SafeArrayGetLBound safearray (1+ i)))
			(ubound (%SafeArrayGetUBound safearray (1+ i))))
		(push (- ubound lbound -1) dims)))))

(defun safearray-to-lisp (safearray &optional raw)
  "Convert SAFEARRAY to lisp ARRAY."
  (let ((array (make-array (safearray-dimensions safearray))))
	(for-all-elements
	 (array-dimensions array)
	 (lambda (subscripts)
	   (let ((subs (make-array (array-rank array) :initial-contents subscripts)))
		 (setf (apply #'aref array subscripts)
			   (variant-get (%SafeArrayGetElement safearray subs) raw)))))
	array))

;; (let ((array (make-array '(4 2 3)
;; 						 :initial-contents '((("a" "b" "c") (1 2 3))
;; 											 (("d" "e" "f") (3 1 2))
;; 											 (("g" "h" "i") (2 3 1))
;; 											 (("j" "k" "l") (0 0 0))))))
;;   (let ((safearray (safearray-from-lisp array)))
;; 	(with-safearray safearray
;; 	  (safearray-to-lisp safearray))))

;;; wrappers and utilities

;; (def-ole-interface IUnknown ()
;;   (QueryInterface (p a b))
;;   (AddRef (p))
;;   (Release (p)))

;; (def-ole-interface IDispatch (IUnknown)
;;   (GetTypeInfoCount (p a))
;;   (GetTypeInfo (p a b c))
;;   (GetIDsOfNames (p a b c d e))
;;   (Invoke (p a b c d e f g h)))