clisp-ole

ole.lisp (21183B)

---

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