Lisp from .NET using COM

Here’s another silly example.

Calling a Lisp COM-server from .NET(use RDNZL to load compiled assembly into Lisp and call LispCOM.Foo)

using System;
using System.Runtime.InteropServices;

namespace LispCOM
{
    [Guid("F9210244-38D1-49C0-A848-684EDD3DBFF0"),
     InterfaceType(ComInterfaceType.InterfaceIsIUnknown)]
    interface IHelloWorld
    {
        void HelloWorld([In, MarshalAs(UnmanagedType.LPWStr)] string message);
    }

    [ComImport, Guid("DF748DA7-BCB9-4F67-8D32-F9AA1AAA3ABF")]
    class HelloWorld
    {
    }

    public class LispCOM
    {
        public static void Foo()
        {
            try
            {
                IHelloWorld helloWorld = (IHelloWorld)(new HelloWorld());
                helloWorld.HelloWorld("Hello from .NET!");
            }
            catch (Exception e)
            {
                Console.WriteLine("Exception: {0}", e.Message);
            }
        }
    }
}

Current status of the library is as follows(tested under Windows 2000 and Windows 7 on x86):

clisp – works

SBCL – works. But, you’ll need to use patched version of SBCL(Which you can obtain here: sources and binaries) to work with COM. Anton Kovalenko(a developer, who is currently working on improving SBCL port for Windows) has recently added support for stdcall callbacks(which is a vital thing for COM interop) to Dmitry Kalyanov’s fork of SBCL. Oh, and, here’s the patch for CFFI.

Clozure CL – COM interop works only partially. Some problems with callbacks. I will try to fix them, though.

COM-WRAPPER

Today i’ve added COM-WRAPPER-CLASS and COM-WRAPPER classes to Doors.

COM-WRAPPER is roughly identical to .NET’s “Runtime callable wrapper” – its instances encapsulate underlying COM objects and all of their interface pointers.

COM-WRAPPER’s SHARED-INITIALIZE method uses CoCreateInstanceEx function to obtain pointer to IUnknown interface and then it uses IUnknown::QueryInterface to obtain other pointers.

Wrappers are garbage-collected, meaning that you should not bother about manually calling AddRef/Release functions.

Here’s an example. Note that it uses HELLO-WORLD-OBJECT class, which is described in the previous post.

(defclass hello-world-wrapper (com-wrapper)
  ()
  (:metaclass com-wrapper-class)
  ;;A list of interfaces implemented by this class:
  (:interfaces hello-world)
  ;; In case when :clsid is a string,
  ;; CLSIDFromString function is used to obtain a GUID structure.
  (:clsid . "{DF748DA7-BCB9-4F67-8D32-F9AA1AAA3ABF}"))

;;An example
;;  (which of course implies that you've already registered
;;            a HELLO-WORLD-OBJECT server):
;(defvar *wrapper* (make-instance 'hello-world-wrapper))
;(hello-world *wrapper*) ;; ==> 'Hello, world!' message on *STANDARD-OUTPUT*

COM-CLASS metaobjects

I’ve updated Doors this morning.

COM-CLASS metaobjects are now COM-OBJECTs themselves, meaning that you can acquire their interfaces and so on.

Therefore, an example described in the previous post could be simplified to this:

(define-interface hello-world
    ((iid-hello-world
       #xF9210244 #x38D1 #x49C0
       #xA8 #x48 #x68 #x4E #xDD #x3D #xBF #xF0)
     unknown)
  (hello-world (hresult)
      (string (& wstring) :optional "Hello, world!")))

(define-guid clsid-hello-world
  #xDF748DA7 #xBCB9 #x4F67
  #x8D #x32 #xF9 #xAA #x1A #xAA #x3A #xBF)

(defclass hello-world-object (com-object)
  ()
  (:metaclass com-class)
  (:clsid . clsid-hello-world))

(defmethod hello-world ((object hello-world-object)
                        &optional (string "Hello, world!"))
  (write-line string)
  (values nil string))

(defmethod lock-server ((class (eql (find-class 'hello-world-object))) lock)
  (if lock
    (add-ref class)
    (release class))
  (values nil lock))

(defmethod create-instance
    ((class (eql (find-class 'hello-world-object))) iid &optional outer)
  (if outer
    (error 'com-error :code error-not-implemented)
    (progn
      (unless (member (class-name iid)
                      '(unknown hello-world))
        (error 'com-error :code error-no-interface))
      (let ((object (make-instance class)))
        (values nil outer iid (acquire-interface object iid))))))

(defun register-server ()
  (handler-bind
    ((windows-status #'muffle-warning))
    (initialize))
  (register-class-object 'hello-world-object :server :multiple-use))

COM interop in Doors

Last week i’ve been working mainly on improving COM-related part of Doors.

As i have mentioned before, Doors allows two-way interoperability with COM.

This means Doors allows you not only to use external interfaces, but also to define you own COM classes, and pass their instances’ interfaces into foreign code.

As you probably know, COM is a binary standard of an object model, the core concept of which is a so-called COM-interface, which is basically a pointer to an array of functions(a so-called virtual method table). COM specification requires that the only way to gain access to the methods of an interface is through a pointer to the interface.

The specification does not mention anything about the actual object which implements an interface, therefore completely separating interface from its implementation. An interface may be a part of an actual object, which is, as far as i know, the case of Visual C++, or it may be a simple proxy, which delegates interface implementation to something else. The latter case is exactly how COM interfaces are implemented in Doors.

Every lisp-side COM object(an instance of COM-OBJECT class, or any of its descendants) holds a hash-table, which maps interface classes to pointers, each of which points to a block of memory which holds a pointer to a method table. Those blocks of memory are allocated during a call to ACQUIRE-INTERFACE function(and are allocated only once for each interface class) and deallocated inside the object’s finalizer(i.e. during the process of garbage collection). By the way, objects will not be garbage collected until their reference count reaches zero.

Instance of COM-OBJECT A hash-table A block of foreign memory -------------------- ---------------------------- ------------------------------- [ interface pointers ] ----> [ interface class metaobject ] -----> [ a pointer to the method table ] -------------------- ---------------------------- ------------------------------- [ ref-count ] [ ... ] -------------------- ---------------------------- [ other slots ] [ ... ] --------------------

Method tables are constructed inside DEFINE-INTERFACE macro. Every function inside a method table is a simple trampoline which translates arguments into lisp values and calls corresponding generic function. ‘this’ argument is translated by performing a lookup in the global hash-table which maps interface pointers to lisp objects.

Methods with HRESULT return type are treated in a special way. Trampoline establishes handlers, which translate lisp errors into HRESULT codes. Warnings are also handled, but unlike errors, they do not cause stack unwinding, allowing generic function to proceed execution.

IUnknown method table --------------------------- [ QueryInterface trampoline ] -------------> QUERY-INTERFACE generic function --------------------------- [ AddRef trampoline ] -------------> ADD-REF generic function --------------------------- [ Release trampoline ] -------------> RELEASE generic function ---------------------------

Interfaces, by the way, are also represented as CLOS objects. An interface object is a simple wrapper around a pointer. Generic functions’ methods which are specialized on interface classes perform translation of lisp values into foreign values and invoke corresponding foreign functions from the interfaces’ method tables. Those methods are defined inside DEFINE-INTERFACE macro, but you can redefine them using DEFINE-INTERFACE-METHOD.

Instance of COM-INTERFACE ------------------------- [ pointer ] -----------------> Actual COM interface ------------------------- [ other slots ] [ ... ] ------------------------- IUnknown method table ----------------------- QUERY-INTERFACE ((interface UNKNOWN) iid) -----> [ QueryInterface method ] ADD-REF ((interface UNKNOWN)) ----------> [ AddRef method ] RELEASE ((interface UNKNOWN)) ----------> [ Release method ]

Here’s an example. Registering a simple COM server, which is able to output a string to the console.

(define-interface hello-world ;;interface class name
    ((iid-hello-world
       ;;Interface identifier.
       ;;this particular guid has been generated by
       ;;DOORS.COM:CREATE-GUID function
       #xF9210244 #x38D1 #x49C0
       #xA8 #x48 #x68 #x4E #xDD #x3D #xBF #xF0)
     ;;parent interface class:
     unknown)
  ;;(defmethod hello-world ((interface hello-world)
  ;;                        &optional (string "Hello, world!"))
  ;;    ...)
  (hello-world (hresult)
      ;;(& wstring) is translated into a pointer to utf-16 string
      (string (& wstring) :optional "Hello, world!")))

;;define-guid macro defines a constant variable which holds GUID structure
(define-guid clsid-hello-world
  #xDF748DA7 #xBCB9 #x4F67
  #x8D #x32 #xF9 #xAA #x1A #xAA #x3A #xBF)

;;the actual object class
(defclass hello-world-object (com-object)
  ;;this slot is required to implement IClassFactory::LockServer
  ((locked :initform nil :accessor hwo-locked-p))
  (:metaclass com-class)
  (:clsid . clsid-hello-world))

(defmethod hello-world ((object hello-world-object)
                        &optional (string "Hello, world!"))
  (write-line string)
  ;; (values ...) form is required to support arguments of
  ;; reference types(particulary :inout and :out ones).
  ;; Every method that could be called inside a trampoline
  ;;  must return all of its arguments as multiple values
  ;;  in order that is specified in the interface definition
  (values nil string))

(defmethod lock-server ((object hello-world-object) lock)
  (if (hwo-locked-p object)
    (if lock
      (warn 'windows-status :code status-false)
      (progn (release object)
             (setf (hwo-locked-p object) nil)))
    (if lock
      (progn (add-ref object)
             (setf (hwo-locked-p object) t))
      (warn 'windows-status :code status-false)))
  (values nil lock))

(defmethod create-instance
    ((object hello-world-object) iid &optional outer)
  (if outer
    (error 'com-error :code error-not-implemented)
    (progn
      (unless (typep iid 'com-interface-class)
        (setf iid (find-interface-class iid)))
      (unless (member (class-name iid)
                      ;; HELLO-WORLD-OBJECT implements only
                      ;; IUnknown, IClassFactory and HELLO-WORLD interfaces
                      '(unknown class-factory hello-world))
        (error 'com-error :code error-no-interface))
      (let ((object (make-instance 'hello-world-object)))
        (values nil outer iid (acquire-interface object iid))))))

(defun register-server ()
  (handler-bind
    ((windows-status #'muffle-warning))
    ;;CoInitialize may return S_FALSE(0x00000001)
    (initialize))
  (let* ((object (make-instance 'hello-world-object))
         (unknown (acquire-interface object 'unknown t))
         (register (register-class-object ;;CoRegisterClassObject
                     'hello-world-object ;;CLSID
                     unknown ;;an interface pointer
                     :server ;;CLSCTX_SERVER
                     :multiple-use))) ;;REGCLS_MULTIPLEUSE
    (values register object)))

;;After calling REGISTER-SERVER we can create
;;instances of hello-world-object
;;using CoCreateInstance/CoGetClassObject
;;An example:
;(defvar *hello-world-interface* (create-com-instance ;;CoCreateInstance
;                                    'hello-world-object ;;CLSID
;                                    'hello-world ;;IID
;                                    nil
;                                    :server))
;(hello-world *hello-world-interface*) ;; outputs 'Hello, world!' to *STANDARD-OUTPUT*

This server can also be called from foreign code.
I.e.

// You'll need Microsoft Visual C++ compiler to compile this.
// cl.exe /LD doors_com_example.cpp ole32.lib
// Then you should load the library into lisp using cffi:load-foreign-library
// And then call "foo" function using cffi:foreign-funcall
// i.e. (cffi:foreign-funcall "foo" :void)
// If everything goes well, you'll notice "Hi there" message on the console
#include <stdlib.h>
#include <stdio.h>
#include <windows.h>

const CLSID CLSID_HelloWorld = {0xdf748da7, 0xbcb9, 0x4f67,
                                {0x8D, 0x32, 0xf9, 0xaa, 0x1a, 0xaa, 0x3a, 0xbf}};

const IID IID_IHelloWorld = {0xf9210244, 0x38d1, 0x49c0,
                             {0xa8, 0x48, 0x68, 0x4e, 0xdd, 0x3d, 0xbf, 0xf0}};

typedef interface IHelloWorld IHelloWorld;
extern "C++"
{
    MIDL_INTERFACE("DF748DA7-BCB9-4F67-8D32-F9AA1AAA3ABF")
    IHelloWorld : public IUnknown
    {
        public:
                virtual HRESULT STDMETHODCALLTYPE HelloWorld(
                        /* [in] */ LPCWSTR message
                        ) = 0;
    };
}

extern "C"
{
    void __declspec(dllexport) foo()
    {
        IClassFactory* factory = NULL;
        IHelloWorld* helloWorld = NULL;
        HRESULT hr = 0;
        hr = CoGetClassObject(CLSID_HelloWorld, CLSCTX_INPROC_SERVER,
                              NULL, IID_IClassFactory, (void**)&factory);
        if(FAILED(hr))
        {
            printf("Failure: %08X\n", hr);
            return;
        }
        hr = factory->CreateInstance(NULL, IID_IHelloWorld, (void**)&helloWorld);
        if(FAILED(hr))
        {
            printf("Factory failure: %08X\n", hr);
            factory->Release();
            return;
        }
        hr = helloWorld->HelloWorld(L"Hi there!");
        if(FAILED(hr))
        {
            printf("HelloWorld failure: %08X\n", hr);
        }
        factory->Release();
        helloWorld->Release();
    }
}

Note for SBCL users:

COM interface methods use stdcall calling convention. And unfortunately, SBCL does not support stdcall callbacks at the moment, so passing lisp interfaces into foreign code will likely cause stack corruption and will likely result in weird errors, such as EXCEPTION_PRIV_INSTRUCTION.  Although, i’m going to implement some workaround in Virgil in the future.