COM and Automation Support for XLISP-STAT on Windows

Table of Contents

Introduction

Eventually this interface will be folded into the standard distribution. For now, it is made available as a zip file, win32com.zip. This file should be unpacked in the Autoload subdirectory of the Xlisp-Stat tree. This will insure that the interface is loaded when it is used. Be sure to preserve the directory structure when unpacking the zip file. You will also need the Win32 support library.

If you want to install the COM server, you need to run the following command after unpacking the code. This command will need to be run again if you move the location of the Lisp-Stat directory.

wxls32.exe Autoload/win32com/server -RegServer

wxls32.exe Autoload/win32com/server -UnregServer

This writeup still needs lots of work but is hopefully enough to get you started. Almost everything in this interface should be viewed as preliminary and subject to change.

Interface and Examples

Client Interface

Initial Object Creation

[Function]
create-object cls-spec &key :server

Creates a new object on the specified server; the default server is the local machine. The cls-spec can be a ProgID string or a class GUID. For example,

(create-object "Excel.application")

create-object takes a few additional keyword arguments but these are currently not particularly useful.

[Function]
get-object moniker

Creates a new object as specified by the moniker string. Typically this string will be a file name. For example,

(get-object "...\\cars.xls")

[Function]
get-active-object class-spec

Returns the active object for cls-spec if one is registered. class-spec can be a ProgID or a class GUID.

Invoking Methods

[Function]
invoke object name &rest args

Invokes method name of object on the arguments and returns the resulting value. name can be a string or a symbol; method names are not case sensitive. For example,

(invoke engine :OpenDatabase "Northwind.mdb")

[Function]
invoke-no-value object name &rest args

The same as invoke, but no value is returned.

Using invoke-no-value can be more efficient since it avoids the overhead of transferring the value from the server back to the client. It can also avoid errors if the server does not return a value---this seems to be the case for some methods in Word.

Reading and Setting Properties

Returns the value of the property name of object. name can be a string or a symbol; property names are not case sensitive. For example,

  (property app :visible)

  (property wb :worksheets 1)

[Setf]
(setf (property object name {arg}*) value)

Assigns value to property name in object. The expression

(setf (property add :visible) t)

Client Examples

Accessing Excel

<excel client example>= [D->]
(setf wb (get-object "...\\cars.xls"))

starts an Excel server and opens the workbook. These two steps can also be done separately by

<excel client example>+= [<-D->]
(setf xl (create-object "Excel.application"))
(setf wb (invoke (property xl :workbooks) :open "...\\cars.xls"))

The expression

<excel client example>+= [<-D->]
(setf sheet (property wb :worksheets 1))

obtains a reference to the first worksheet in the workbook and assigns it to the variable sheet.

Excel allows the rectangular region containing a specified cell and bordered by empty cells to be obtained by the CurrentRegion property of the cell. Thus, assuming that all the data are in a contiguous rectangular region, the data can be read from Excel into Lisp-Stat with the expression

<excel client example>+= [<-D->]
(let ((range (property (property sheet :cells 1 1) :CurrentRegion)))
  (setf data  (property range :value)))

The result contained in the data variable is a Lisp-Stat matrix:

> data
#2A(("Mazda RX4"     21.0 6.0 160.0 110.0 ...)
    ("Mazda RX4 Wag" 21.0 6.0 160.0 110.0 ...)
    ...) 

<excel client example>+= [<-D]
(let ((cols (column-list data)))
  (setf car-spin (spin-plot (select cols '(1 3 4)))))

Using A Data Base

<database client example>= [D->]
(let* ((engine (create-object "DAO.DBEngine.35"))
       (db (invoke engine :OpenDatabase <database file name>))
       (rs <open database record set>))
  (unwind-protect
      <operate on the record set>
    (invoke rs :close)
    (invoke db :close)))

This example uses the sample data base supplied with MS Access,

<database file name>= (<-U U->)
"\\Program Files\\Microsoft Office\\Office\\Samples\\Northwind.mdb"

The record set used corresponds to the UnitPrice variable in the Products table of the data base.

<open database record set>= (<-U)
(invoke db :OpenRecordset "SELECT UnitPrice FROM Products")

The operation performed is to construct a histogram of the prices. This is done by first looping through the record set and extracting the prices into a list, and then making a histogram of the list.

<operate on the record set>= (<-U)
(let ((prices nil))
  (loop
   (when (property rs :EOF) (return))
   (push (property (property rs :fields "UnitPrice") :value) prices)
   (invoke rs :MoveNext))
  (histogram prices))

An alternative way to open the database is to use get-object to start an Access server with the data base, and then obtain a reference to the database object as the CurrentDB property of the server object:

<database client example>+= [<-D->]
(property (get-object <database file name>) :currentdb)

Record sets can be created from any SQL query supported by the engine. Some more examples:

<database client example>+= [<-D]
(invoke db :OpenRecordset
        "SELECT * FROM Employees ORDER BY LastName, FirstName"))
(invoke db :OpenRecordset 
        (concatenate 'string
                     "SELECT CompanyName,Region,Country FROM Customers "
                     "WHERE Country = 'Canada' ORDER BY CompanyName"))

Using MS Agent

Table [->] shows the MS IDL for the IAgent interface, which can be obtained from the OleView browser.

[
  odl,
  uuid(A7B93C91-7B81-11D0-AC5F-00C04FD97575),
  helpstring("IAgent Interface"),
  dual,
  oleautomation
]
interface IAgent : IDispatch {
    [id(0x60020000)]
    HRESULT _stdcall Load(
                    [in] VARIANT vLoadKey, 
                    [out] long* pdwCharID, 
                    [out] long* pdwReqID);
    [id(0x60020001)]
    HRESULT _stdcall Unload([in] long dwCharID);
    [id(0x60020002)]
    HRESULT _stdcall Register(
                    [in] IUnknown* punkNotifySink, 
                    [out] long* pdwSinkID);
    [id(0x60020003)]
    HRESULT _stdcall Unregister([in] long dwSinkID);
    [id(0x60020004)]
    HRESULT _stdcall GetCharacter(
                    [in] long dwCharID, 
                    [out] IDispatch** ppunkCharacter);
    [id(0x60020005)]
    HRESULT _stdcall GetSuspended([out] long* pbSuspended);
};

MS IDL for the IAgent Interface [*]

To start off, we need an agent server:

<MS Agent example>= [D->]
(setf agent-server (create-object "Agent.Server.2"))

Next, we need to load one of the standard characters. The function

<MS Agent example>+= [<-D->]
(defun load-agent-character (server character-name)
  (let ((v1 (make-variant-ref nil VT_I4))
        (v2 (make-variant-ref nil VT_I4)))
    (invoke-no-value server :load character-name v1 v2)
    (let ((char-ref (variant-ref-value v1))
          (v3 (make-variant-ref nil VT_DISPATCH)))
      (invoke-no-value server :getcharacter char-ref v3)
      (values (variant-ref-value v3) char-ref))))

Defines load-agent-character (links are to index).

does this. make-variant-ref takes an initial value, here nil, and a type specification and returns a variant reference object. Two are needed for the call to the Load method of the server. The first receives the character reference index, which is extracted with variant-ref-value. The second out parameter receives the request ID and is ignored by this function. Many methods that initiate an asynchronous action return a request ID; I think this allows cancellation. Once the character index is available, a reference to the character itself is obtained by the GetCharacter method. Again the result is returned in a variant reference. The load-agent-character function returns both the character object reference and the index since the index is needed to unload the character.

The character Merlin is loaded by

<MS Agent example>+= [<-D->]
> (load-agent-character agent-server "Merlin.acs"))
#<IDISPATCH IAgentCharacterEx>
258

Other standard characters that may be installed are Genie, Robby, and Peedy.

Most of the operations on a character return a request ID through an out parameter. It is therefore more convenient to write some functions for them. This, and the wrapping of the Load method above, could and should be done automatically based on the IDL itself or on a Lisp-like IDL declaration, but for now you need to do it by hand. One approach to automating this is shown later in this section.

<MS Agent example>+= [<-D->]
(defun agent-character-show (char &optional fast)
  (let ((v (make-variant-ref nil VT_I4)))
    (invoke-no-value char :show (if fast t nil) v)
    (variant-ref-value v)))

(defun agent-character-speak (char text &optional (url ""))
  (let ((v (make-variant-ref nil VT_I4)))
    (invoke-no-value char :speak text url v)
    (variant-ref-value v)))

(defun agent-character-play (char action)
  (let ((v (make-variant-ref nil VT_I4)))
    (invoke-no-value char :play action url v)
    (variant-ref-value v)))

(defun agent-character-move-to (char x y speed)
  (let ((v (make-variant-ref nil VT_I4)))
    (invoke-no-value char :moveto x y speed v)
    (variant-ref-value v)))

(defun agent-character-think (char text)
  (let ((v (make-variant-ref nil VT_I4)))
    (invoke-no-value char :think text v)
    (variant-ref-value v)))

(defun agent-character-hide (&optional fast)
  (let ((v (make-variant-ref nil VT_I4)))
    (invoke-no-value char :hide (if fast t nil) v)
    (variant-ref-value v)))

The following expressions make use of these functions. They assume that a character is stored in the variable c.

<MS Agent example>+= [<-D->]
(agent-character-show c)
(agent-character-speak c "Hello")
(agent-character-play c "Greet")
(agent-character-speak c "Hello, World!")
(agent-character-play c "Wave")
(agent-character-move-to c 700 100 50)
(agent-character-think c "Hello")
(agent-character-think c "Hello")
(invoke agent-server :unload 258)

Another approach to handling an interface like this would be to wrap references in Lisp-Stat objects. A prototype for the server wrapper could be defined to contain a slot for the COM reference.

<agent-server prototype>= (U->) [D->]
(export 'agent-server)
(defproto agent-server '(com-reference))

Defines agent-server (links are to index).

The initialization method creates a new COM server and installs its reference.

<agent-server prototype>+= (U->) [<-D->]
(defmeth agent-server :isnew ()
  (setf (slot-value 'com-reference) (create-object "Agent.Server.2")))

Defines :isnew (links are to index).

To simplify connecting Lisp-Stat methods to the COM methods we can define a macro define-agent-method. Using this macro, which is given below, the Load method and the GetCharacter method from the IDL are connected to methods for agent-server by

<agent-server prototype>+= (U->) [<-D->]
(define-agent-method agent-server base-load
  (file (:out char-ref VT_I4) (:out req-id VT_I4))
  :load)
(define-agent-method agent-server get-character
  (char-ref (:out char VT_DISPATCH))
  :GetCharacter)

Defines get-character, load (links are to index).

The names for these methods are internal symbols in the MS-AGENT package rather than keyword symbols since they are intended to be used only within the package.

A method that combines these two and also wraps the COM character reference in a Lisp-Stat object is defined as

<agent-server prototype>+= (U->) [<-D]
(defmeth agent-server :load-character (file)
  (let* ((char-ref (send self 'base-load file))
         (char (send self 'get-character char-ref)))
    (send agent-character :new char char-ref self)))

Defines :load-character (links are to index).

This is the public character loading method.

Loading a character that is already loaded does not seem to work; it might be a good idea to have the server keep track of which characters are loaded and only load new ones if they are not loaded already. This sort of thing would probably require a reference/lock count on the character. The server might also provide a higher level character naming interface so users would not need to remember the .acs file name extension.

The character representation is defined by a prototype containing slots for a COM reference, the server that produced the character, and the character reference index returned by the server Load method. This prototype is not exported since new characters should only be created by the sending a server a :load-character message.

<agent-character prototype>= (U->) [D->]
(defproto agent-character '(com-reference server char-ref))

Defines agent-character (links are to index).

The initialization method is

<agent-character prototype>+= (U->) [<-D->]
(defmeth agent-character :isnew (comref char-ref server)
  (setf (slot-value 'com-reference) comref)
  (setf (slot-value 'char-ref) char-ref)
  (setf (slot-value 'server) server))

Defines :isnew (links are to index).

Since the character contains a reference to its server as well as its reference index, unloading can now be handled by a character method:

<agent-character prototype>+= (U->) [<-D->]
(defmeth agent-character :unload ()
  (let ((server (send (slot-value 'server) :slot-value 'com-reference)))
    (invoke-no-value server :unload (slot-value 'char-ref))))

Defines :unload (links are to index).

Here are some basic character methods:

<agent-character prototype>+= (U->) [<-D]
(define-agent-method agent-character :show
  ((:optional fast nil) (:out req-id VT_I4)))
(define-agent-method agent-character :hide
  ((:optional fast nil) (:out req-id VT_I4)))
(define-agent-method agent-character :position
  ((:out x VT_I4) (:out y VT_I4)) :GetPosition)
(define-agent-method agent-character :set-position (x y) :SetPosition)
(define-agent-method agent-character :move-to
  (x y speed (:out req-id VT_I4)) :MoveTo)
(define-agent-method agent-character :think (text (:out req-id VT_I4)))
(define-agent-method agent-character :play (action (:out req-id VT_I4)))
(define-agent-method agent-character :speak
  (text (:optional url "") (:out req-id VT_I4)))

Defines :hide, :move-to, :play, :position, :set-position, :show, :speak, :think (links are to index).

Here are a few examples:

<MS Agent example>+= [<-D]
(setf s (send ms-agent:agent-server :new))
(setf c (send s :load-character "Merlin.acs"))
(send c :show)
(send c :speak "Hello")
(send c :play "Greet")
(send c :speak "Hello, World!")
(send c :play "Wave")
(send c :position)
(send c :set-position 100 100)
(send c :move-to 700 100 50)
(send c :think "Hello")
(send c :unload)

Finally we need to define the define-agent-method macro. This definition illustrates how the information available in IDL can be used to construct a Lisp interface. The macro is called with the object, the Lisp-Stat method name, an argument list, and an optional COM method name as arguments; the COM method name defaults to the Lisp-Stat one.

<define-agent-method macro>= (U->)
(defmacro define-agent-method (object name args &optional (comname name))
  (let ((invars nil)
        (optargs nil)
        (outargs nil)
        (callargs nil))
    <process args into invars, optargs, outargs, and callargs>
    (let ((arglist <construct the agent method lambda list>)
          (binds <construct bindings for the out parameters>)
          (vals <construct the agent method value expressions>))
      `(defmeth ,object ,name ,arglist
         (let ,binds
           (invoke-no-value (slot-value 'com-reference) ',comname ,@callargs)
           (values ,@vals))))))

Defines define-agent-method (links are to index).

The argument list entries can be symbols or lists. Symbols are treated as standard in arguments. Lists must start with :out or :optional. :out lists represent out parameters; the :out symbol must be followed by a variable symbol and a VARIANT type. :optional lists represent optional parameters; the second term in the list must be a symbol naming the variable and the third must be an expression for the default value. :out arguments can appear anywhere; all arguments following an :optional argument must be either :out or :optional. None of this is checked. The argument list is processed into the standard in arguments and the out and optional arguments; the arguments for the COM method invocation are also accumulated.

<process args into invars, optargs, outargs, and callargs>= (<-U)
(dolist (a args)
  (if (symbolp a)
      (progn (push a invars) (push a callargs))
    (case (first a)
          (:optional (push (rest a) optargs)
                     (push (second a) callargs))
          (:out (push (rest a) outargs)
                (push (second a) callargs)))))
(setf invars (nreverse invars))
(setf optargs (nreverse optargs))
(setf outargs (nreverse outargs))
(setf callargs (nreverse callargs))

The invocation is contained in a let binding that creates references for returning the out parameters. The bindings are constructed by

<construct bindings for the out parameters>= (<-U)
(mapcar (lambda (x)
          `(,(first x) (make-variant-ref nil ,(second x))))
        outargs)

The lambda list for the method definition is built by

<construct the agent method lambda list>= (<-U)
(if optargs `(,@invars &optional ,@optargs) invars)

and the expressions for the values to be returned by the method are constructed by

<construct the agent method value expressions>= (<-U)
(mapcar (lambda (x) `(variant-ref-value ,(first x))) outargs)

The agent interface is contained in the file msagent.lsp.

<msagent.lsp>=
(defpackage "MICROSOFT-AGENT" (:nicknames "MS-AGENT") (:use "XLISP" "COM"))
(in-package "MS-AGENT")
<define-agent-method macro>
<agent-server prototype>
<agent-character prototype>

Reflection

Here is a function that lists all the methods (actually methods and properties) the interface of an Automation object exposes.

<reflection>= [D->]
(defun com-methods (ref &optional full)
  (let ((info (idispatch-type-info ref)))
    (unless info (error "no type information available"))
    (com-info-methods info full)))

Defines com-methods (links are to index).

It uses the function com-info-methods to get the information it needs from a type information object.

<reflection>+= [<-D->]
(defun com-info-methods (info full)
  (let* ((desc (itypeinfo-function-descriptions info))
         (names (mapcar #'ninth desc)))
    (if full names (mapcar #'first names))))

Defines com-info-methods (links are to index).

The function com-info-methods returns either a list of method names or a list of lists with each list containing the method name followed by its arguments.

As an example, suppose we open an Excel workbook and ask it for information on its methods.

> (setf wb (get-object "...\\cars.xls"))
#<IDISPATCH _Workbook>
> (com-methods wb)
("QueryInterface" "AddRef" "Release" "GetTypeInfoCount" "GetTypeInfo"
 "GetIDsOfNames" "Invoke" "Application" "Creator" "Parent"
 "AcceptLabelsInFormulas" "AcceptLabelsInFormulas" "Activate" ...)

Instead of using the full argument, we could extract the signature. One (inefficient) way to do this uses

<reflection>+= [<-D->]
(defun com-method-signature (ref name)
  (let ((info (idispatch-type-info ref)))
    (unless info (error "no type information available"))
    (com-info-method-signature info name)))

(defun com-info-method-signature (info name)
  (ninth (find (string name) (itypeinfo-function-descriptions info)
               :test #'string-equal
               :key #'(lambda (x) (first (ninth x))))))

For the Activate method of our workbook this gives

> (com-method-signature wb "Application")
("Application")

A similar set of functions can be used to extract the method names (i.e. the events) or signatures for an event source:

<reflection>+= [<-D]
(defun com-events (object &optional full)
  (let* ((lib (itypeinfo-type-lib (idispatch-type-info object)))
         (iid (first (get-source-interfaces object))))
    (when iid
      (let ((info (itypelib-type-info-of-guid lib iid)))
        (when (eq :dispatch (itypeinfo-kind info))
          (com-info-methods info full))))))

(defun com-event-signature (object name)
  (let* ((lib (itypeinfo-type-lib (idispatch-type-info object)))
         (iid (first (get-source-interfaces object))))
    (when iid
      (let ((info (itypelib-type-info-of-guid lib iid)))
        (when (eq :dispatch (itypeinfo-kind info))
          (com-info-method-signature info name))))))

Defines com-events (links are to index).

For the workbook:

> (com-events wb)
("QueryInterface" "AddRef" "Release" "GetTypeInfoCount" "GetTypeInfo"
 "GetIDsOfNames" "Invoke" "Open" "Activate" "Deactivate" "BeforeClose"
 "BeforeSave" "BeforePrint" "NewSheet" "AddinInstall" "AddinUninstall"
 "WindowResize" "WindowActivate" "WindowDeactivate" "SheetSelectionChange"
 "SheetBeforeDoubleClick" "SheetBeforeRightClick" "SheetActivate"
 "SheetDeactivate" "SheetCalculate" "SheetChange")
> (com-event-signature wb :newsheet)
("NewSheet" "Sh")

Value Conversion

Automatic Conversion for Basic Value Types

Description	Variant Type	Lisp Type
Array	VT_ARRAY	(array t)
Empty	VT_EMPTY	(eql :empty)
Null	VT_NULL	(eql :null)
1-Byte unsigned int	VT_UI1	fixnum
2-Byte signed int	VT_I2	fixnum
4-Byte signed int	VT_I4	fixnum
4-Byte real	VT_R4	float
8-Byte real	VT_R8	float
Currency	VT_CY	rational
String	VT_BSTR	string
Error Code	VT_ERROR	fixnum
Boolean	VT_BOOL	(or null (eql t))
Date	VT_DATE	float
Automation Object	VT_DISPATCH	idispatch
Variant	VT_VARIANT	variant
COM Object	VT_UNKNOWN	iunknown

VARIANT to Lisp Conversion [*]

Default conversion from Lisp values to VARIANT values is shown in Table [->].

Description	Lisp Type	Variant Type
Array	(and array (not string))	VT_ARRAY of VARIANT
Symbol nil	null	VT_BOOL False
Symbol t	(eql t)	VT_NULL True
Fixnum	fixnum	VT_I4
Float	float	VT_R8
String	string	VT_BSTR
Automation Object Reference	idispatch	VT_DISPATCH
Variant	variant	VT_VARIANT
COM Object Reference	iunknown	VT_UNKNOWN
COM Server Object	inherits from com-server	VT_DISPATCH

Lisp to VARIANT Conversion [*]

Empty and Null Values

(let ((*empty-variant-value* :missing))
  (property sheet :cells i j))

Explicit Variant Passing and Conversion

[Function]
make-variant arg &optional type

Constructs a VARIANT with value arg and type type. If type is omitted, then the default from Table [<-] is used.

[Function]
variant-value var

Returns the Lisp value of VARIANT var as given in Table [<-].

[Function]
variant-change-type var type

Creates a new VARIANT with type type and value corresponding to the value of the VARIANT var

[Function]
variant-value-as var type

This is shorthand for (variant-value (variant-change-type var type)).

As one example, VT_DATE values are stored as a floating point number containing days since December 30, 1899 (i.e. for that date the value is zero):

> (variant-value-as (make-variant "12/30/1899") VT_DATE)
0.0
> (variant-value-as (make-variant "January 17, 2000") VT_DATE)
36542.0

Another case where explicit variant creation may be useful is for currency (VT_CY) values. A currency value is stored as a 64-bit integer n that represents n/10,000 currency units. On conversion to Lisp VT_CY values are converted to rationals using bignum's if necessary, so any VT_CY value is representable in Lisp. Small currency values can be passed as fixnum arguments or float arguments; the server will convert them to currency values. But large currency values requiring bignums will not be handled by automatic conversion; here again explicit variants can be used.

> (variant-value (make-variant 100000000000 VT_CY))
100000000000

COM References and Servers

Responding to Events

<events example>= [D->]
(setf xl (create-object "Excel.application"))
(setf wb (invoke (property xl :workbooks) :open "...\\cars.xls"))
(setf (property xl :visible) t)
(setf sheet (property wb :worksheets 1))
(let* ((range (property (property sheet :cells 1 1) :CurrentRegion))
       (data (property range :value))
       (cols (column-list data)))
  (setf car-spin (spin-plot (select cols '(1 3 4)))))

At this point we might like to edit the data in the spread sheet, and it would be nice if the plot of the data could be updated automatically to reflect any changes we make. This can be arranged by registering an event listener with the sheet object. An event listener for sheet is constructed and connected with

<events example>+= [<-D->]
(setf sheet-listener (send event-server :new sheet))
(send sheet-listener :connect)

Once connected, this object receives notifications from sheet whenever certain events occur as a result of user interaction or executing a program. These events include changes to data and changes to the focus cell, among others. A listing of event names for Excel can be found in a reference such as [cite mcfedries99:_vba_micros_offic], by using a COM browser, or using the utilities described in Section [<-]. The event listener is now a server for which the worksheet is the client.

Notifications are ignored unless the event listener defines an appropriate method. The method name is specified by the source interface for the Worksheet object, and the name of the method called when the sheet's data changes is Change. Here is a simple definition of a Change method for updating the plot when the sheet's data changes:

<events example>+= [<-D]
(defmeth sheet-listener :change (range)
  (let ((cell (property sheet :cells 1 1)))
    (let ((data (property (property cell :CurrentRegion) :value)))
      (let ((cols (column-list data)))
        (send car-spin :clear :draw nil)
        (send car-spin :add-points (select cols '(1 3 4)) :draw nil)
        (send car-spin :adjust-to-data)))))

This definition ignores the range argument that reflects the cells that have changed and simply copies all the data from the spread sheet. A more sophisticated approach would make use of the range argument to reduce the amount of data transferred.

The event handling mechanism is built on the server interface which is described next.

Server Interface

The highest level server interface is implemented by two Lisp-Stat prototype objects.

Automation Server Prototype

Prototype object for COM Automation servers.

[Method]
send server :isnew &optional name

The initialization argument takes a server name string name as an optional argument; the default server name is "Xlisp-Stat".

[Method]
send server :server-name

Returns the server name of server.

[Method]
send server :add-auto-property com-name get-name &optional set-name

Registers a COM property com-name. A property get will send the get-name message; a put will send the set-name message. If set-name is omitted then the property is registered as read-only.

[Method]
send server :add-auto-method com-name name &optional for-value

Registers a COM method com-name. The COM method is handled by sending the object the name message. If for-value is true, the default, a value is returned to the calling client; if it is false, no value is returned.

[Method]
send server :register-active-object class-spec

Registers server as the active object for class-spec. class-spec can be a class GUID or a ProgID string. A server can be registered as the active object for several class-spec values.

[Method]
send server :revoke-active-object &optional class-spec

If class-spec is provided, the registration of server as the active object for class-spec is revoked. Otherwise all active object registrations of server are revoked.

The auto-server prototype has one pre-registered read-only property, Name, which returns the server name.

The auto-server prototype has a number of internal methods that should not be redefined: :MAKE-SERVER, :INVOKE, :GET-IDS-OF-NAMES, :SERVER, and :AUTO-METHODS. Eventually these will either be hidden using the package mechanism or documented as a lower level mechanism.

Class Factories

[Prototype]
class-factory

Class factory prototype.

[Method]
(send factory :isnew proto &key :singleton)

The initialization method requires an object proto as its argument. This object should inherit from auto-server. When :singleton is omitted or nil, proto is sent the :new message with no arguments to produce a new server; a reference to this server is returned to the client requesting the object creation. If :singleton is true, then proto itself is returned.

[Method]
(send factory :register cls-spec)

Registers factory as the class factory for cls-spec, a class GUID or ProgID. A factory can be registered as the factory for several cls-specs but I don't think there is a way to tell which one is requesting object creation.

[Method]
(send factory :revoke &optional cls-spec)

Revoke the class factory registration of factory for cls-spec or for all classes if cls-spec is omitted or nil.

Registering a COM Server

[Function]
register-com-server command clsid friendly-name progid vi-progid

Performs the registry operations needed to register the server. command is a string with the command to start the server, clisd is a CLSID string, and friendly-name is a string used for labeling the registered class in class browsers. The progid string is a ProgID that may include a version number, and vi-progid is the version-independent ProgID string. For the initial version of the Lisp-Stat server progid would be "XlispStat.application.1" and vi-progid would be "XlispStat.application".

[Function]
unregister-com-server clsid progid vi-progid

Removes the server registration for the specified clsid, progid, and vi-progid from the registry.

If you create your own server you will need a CLSID, a GUID (Globally Unique IDentifier) used for a COM class. You can create one with create-guid:

> (create-guid)
#<GUID {776975F0-CE9B-11D3-9F0F-000502DB4890}>

Server Examples

A Lisp-Stat Server

<server.lsp>=
(require "win32")
(require "win32com")
(in-package "WIN32-COM")
<Lisp-Stat server registration>
<Lisp-Stat server implementation>
<Lisp-Stat class factory implementation>
<Lisp-Stat class factory registration>

The registration code attempts to be moderately close to the recommended mechanism for registering server applications. When the server file is loaded, the command line arguments used to start the process are checked. If -RegServer is one of those arguments, the server is registered and the process exits.

<Lisp-Stat server registration>= (<-U) [D->]
(when (find "-RegServer" *command-line* :test #'string=)
  (let ((command (format nil "~awxls32.exe Autoload\\win32com\\server"
                         *default-path*))
        (clsid "{FB4C2CC0-60EF-11D3-8E98-444553540000}")
        (friendly-name "XlispStat COM Server")
        (progid "XlispStat.application.1")
        (vi-progid "XlispStat.application"))
    (register-com-server command clsid friendly-name progid vi-progid))
  (exit))

The CLISD used here is specific to the Lisp-Stat server and should not be re-used. To generate your own CLSID you can call the function create-guid.

Unregistration is analogous: if -UnregServer is in the command line arguments, the server is unregistered and the process exits.

<Lisp-Stat server registration>+= (<-U) [<-D]
(when (find "-UnregServer" *command-line* :test #'string=)
  (let ((clsid "{FB4C2CC0-60EF-11D3-8E98-444553540000}")
        (progid "XlispStat.application.1")
        (vi-progid "XlispStat.application"))
    (unregister-com-server clsid progid vi-progid))
  (exit))

The Lisp-Stat application server is a singleton server; its class factory always returns a reference to the same server object.

<Lisp-Stat server implementation>= (<-U) [D->]
(defparameter *xlispstat-auto-server* (send auto-server :new))

Defines *xlispstat-auto-server* (links are to index).

<Lisp-Stat class factory implementation>= (<-U)
(defparameter *xlispstat-class-factory*
  (send class-factory :new *xlispstat-auto-server* :singleton t))

Defines *xlispstat-class-factory* (links are to index).

The server provides a number of COM methods. The first is a Load method for loading a specified file.

<Lisp-Stat server implementation>+= (<-U) [<-D->]
(defmeth *xlispstat-auto-server* :load (file)
  (load file))
(send *xlispstat-auto-server* :add-auto-method :load :load)

Next, there are three methods for evaluating an expression passed in as a string. The Automation names for these methods are Eval, EvalNoValue, and EvalAllValues. The methods return a single value, no value, or a vector of all values, respectively. ****AllValues--check no values (zero-length array) in VBA--works when WXLS32 is the client.

<Lisp-Stat server implementation>+= (<-U) [<-D->]
(defmeth *xlispstat-auto-server* :eval (expr)
  (eval (read-from-string expr)))
(send *xlispstat-auto-server* :add-auto-method :eval :eval)
(send *xlispstat-auto-server* :add-auto-method :evalnovalue :eval nil)

(defmeth *xlispstat-auto-server* :eval-all-values (expr)
  (coerce (multiple-value-list (eval (read-from-string expr))) 'vector))
(send *xlispstat-auto-server* :add-auto-method :evalallvalues :eval-all-values)

Defines Eval, EvalAllValues, EvalNoValue (links are to index).

Three analogous methods are provided for calling a function. The function is specified as a string; the arguments are passed using the standard conversions. The function string can name a function; it can also be a lambda expression.

<Lisp-Stat server implementation>+= (<-U) [<-D->]
(defmeth *xlispstat-auto-server* :call (fun &rest args)
  (apply (read-from-string fun) args))
(send *xlispstat-auto-server* :add-auto-method :call :call)
(send *xlispstat-auto-server* :add-auto-method :callnovalue :call nil)

(defmeth *xlispstat-auto-server* :call-all-values (fun &rest args)
  (coerce (multiple-value-list (apply (read-from-string fun) args)) 'vector))
(send *xlispstat-auto-server* :add-auto-method :callallvalues :call-all-values)

Defines Call, CallAllValues, CallNoValues (links are to index).

The Create method takes the name of a server prototype, sends it the :new message with the specified arguments, and returns a reference to the new server.

<Lisp-Stat server implementation>+= (<-U) [<-D->]
(defmeth *xlispstat-auto-server* :create (name &rest args)
  (apply #'send (symbol-value (read-from-string name)) :new args))
(send *xlispstat-auto-server* :add-auto-method :create :create)

Defines Create (links are to index).

The Visible property can be used to query or set whether the Lisp-Stat application window is visible or not. Initially it is created invisible by COM, and the server will exit once all references to its objects have been released as long as the main window is not visible.

<Lisp-Stat server implementation>+= (<-U) [<-D]
(defmeth *xlispstat-auto-server* :visible (&optional (vis nil set))
  (if set (msw-main-frame-visible vis) (msw-main-frame-visible)))
(send *xlispstat-auto-server* :add-auto-property :visible :visible :visible)

Defines Visible (links are to index).

The final step in the file is to register the class factory.

<Lisp-Stat class factory registration>= (<-U)
(send *xlispstat-class-factory* :register "XlispStat.application")

Using the Server from Excel

<VBA SpinPlot subroutine>=
Sub SpinPlot(x, y, z)
    Dim xls As Object, sheet As Worksheet, data As Range
    <VBA SpinPlot body>
End Sub

Defines SpinPlot (links are to index).

The first step is to create a new Lisp-Stat application object and save its reference in the variable xls.

<VBA SpinPlot body>= (<-U) [D->]
Set xls = CreateObject("XlispStat.application")

Then we select the data to be used.

<VBA SpinPlot body>+= (<-U) [<-D->]
Set sheet = Application.Workbooks(1).Worksheets(1)
Set data = sheet.Cells(1, 1).CurrentRegion

By convention, COM servers typically are started with no visible user interface. To make the server application visible, its Visible property must be set to True.

<VBA SpinPlot body>+= (<-U) [<-D->]
xls.Visible = True

The basic objective is to call the Lisp-Stat spin-plot function with the data from the specified columns. This function expects a list of three lists or vectors, but data column values produced by Excel are single column matrices. The following expression uses the Lisp-Stat application object's EvalNoValue method to define a function that receives the data in a form natural to Excel, converts the data to the form needed by spin-plot, and makes the call. The EvalNoValue call passes a string argument to Lisp-Stat where the contents of the string are read and evaluated. The value is ignored; this avoids receiving an error since the value returned by defun is a symbol, and there is no default conversion for symbols (other than nil and t).

<VBA SpinPlot body>+= (<-U) [<-D->]
xls.EvalNoValue "(defun sp (x y z)" & _
                "  (flet ((as-seq (x)" & _
                "           (compound-data-seq x)))" & _
                "    (spin-plot (list (as-seq x)" & _
                "                     (as-seq y)" & _
                "                     (as-seq z)))))"

The final step is to call the new function with the contents of the specified columns. This uses the CallNoValue method of the application server.

<VBA SpinPlot body>+= (<-U) [<-D]
xls.CallNoValue "sp", data.Columns(x).Value, _
                      data.Columns(y).Value, _
                      data.Columns(z).Value

An alternate approach would be to create a string containing the lambda expression for the function sp and passing that string to the CallNoValue method. This would avoid cluttering the name space with the function sp.

Distributed Computing

<distributed simulator>= (U->) [D->]
(defun sim (n k d)
  (let ((val (make-array k)))
    (dotimes (i k (mean val))
      (setf (aref val i) (median (chisq-rand n d))))))

Defines sim (links are to index).

The distributed program uses a supervisor/worker model [cite el-rewini98:_distr_paral_comput] in which a supervisor program starts up m worker programs on each of m machines and then collects their results. The workers are implemented by COM servers based on the prototype defined by

<distributed simulator>+= (U->) [<-D->]
(defproto median-simulator () () auto-server)

Defines median-simulator (links are to index).

The simulation on a particular machine is carried out by the :run method of the simulation server.

<distributed simulator>+= (U->) [<-D->]
(defmeth median-simulator :run (n k d receiver)
  (flet ((runner (n k d rcv) (setf (property rcv :value) (sim n k d))))
    (async-call #'runner n k d receiver)))

COM does not yet provide support for asynchronous calls (this will change with COM+ in Windows 2000), so the :run method must start the computation and then return immediately. Ideally this would be done by creating a separate thread to carry out the computation, but this is currently not possible since Lisp-Stat does not yet support multiple threads. Instead an asynchronous call mechanism provided by the async-call function can be used. This mechanism places the call on the event queue, where it is processed in idle time.

<asynchronous function call>= (U->)
(defun async-call (fun &rest args)
  (push (cons fun args) *event-queue*)
  (values))

Defines async-call (links are to index).

To make the Lisp-Stat :run method available as a COM method, it needs to be registered by

<distributed simulator>+= (U->) [<-D]
(send median-simulator :add-auto-method :run :run)

The last argument to the :run method is a value receiver, a COM object owned by the supervisor that accepts the value of the computation as its Value property. This receiver object is also a COM server. It contains a semaphore object that is used to signal when the receiver has been given a value.

<distributed value receiver>= (U->) [D->]
(defproto receiver '(semaphore value) () auto-server)

Defines receiver (links are to index).

The initialization method creates the semaphore locked (count of zero).

<distributed value receiver>+= (U->) [<-D->]
(defmeth receiver :isnew ()
  (call-next-method)
  (setf (slot-value 'semaphore) (make-semaphore 0)))

Defines :isnew (links are to index).

The receiver's :value method waits until the semaphore is released before retrieving the contents of the value slot.

<distributed value receiver>+= (U->) [<-D->]
(defmeth receiver :value ()
  (wait-semaphore (slot-value 'semaphore))
  (slot-value 'value))

Defines :value (links are to index).

The :set-value method places a new value in the value slot and then releases the semaphore.

<distributed value receiver>+= (U->) [<-D->]
(defmeth receiver :set-value (v)
  (setf (slot-value 'value) v)
  (release-semaphore (slot-value 'semaphore)))

Defines :set-value (links are to index).

Together these two methods make up the Value property of the corresponding COM object.

<distributed value receiver>+= (U->) [<-D]
(send receiver :add-auto-property :value :value :set-value)

This receiver is intended to be used only once; otherwise an additional lock would be needed to insure that it is not written before the value has been read.

It is important that the blocking wait for a value occur locally, not in a COM call, since COM is designed for synchronous calls and a wait might be interpreted as a communication failure.

The supervisor is implemented by two functions. The first function starts the simulations. It takes the simulation parameters and a list of machine names as arguments. For each machine the local function start creates a receiver object and starts a Lisp-Stat server on the specified machine. The server is asked to load the file medsim containing the code for the simulation, and is then asked to create a new simulator. Finally, the :run method on this simulator is called to start its work and the receiver is returned. The function start is applied to each machine on the machine list and a list of the receivers is returned.

<distributed supervisor>= (U->) [D->]
(defun start-simulations (n k d machines)
  (flet ((start (mach)
           (let ((rcv (send receiver :new))
                 (app (create-object "XlispStat.application" :server mach)))
             (invoke app :load "medsim")
             (let ((sim (invoke app :create "median-simulator")))
               (invoke sim :run n k d rcv))
             rcv)))
     (map 'list #'start machines)))

Defines start-simulations (links are to index).

Once start-simulations has been called, the simulations are running in parallel on their respective machines and the supervisor needs to collect the results. This is done by the function collect-values. This function requests the value for each receiver and returns a list of the results.

<distributed supervisor>+= (U->) [<-D]
(defun collect-values (receivers)
  (flet ((collect (rcv) (send rcv :value)))
    (map 'list #'collect receivers)))

Defines collect-values (links are to index).

To carry out a simulation using m=2 machines, k=10,000 simulations per machine, samples of size n=10, and d=5 degrees of freedom for the populations sampled, the supervisor would use an expression of the form

(let ((machines (list "192.168.1.3" "192.168.1.10")))
  (collect-values (start-simulations 10 10000 5 machines))))

The code for this example is in the file medsim.lsp.

<medsim.lsp>=
(use-package "WIN32")
(use-package "COM")
<asynchronous function call>
<distributed value receiver>
<distributed simulator>
<distributed supervisor>

This example is of course very simple, but it can be used as the basis for creating a useful framework for managing distributed computations on a network of machines supporting COM.

One issue that I don't yet completely understand is security settings. I ran this example using two NT machines on a local network. To get CreateInstanceEx to work for me as an ordinary user (even on the local machine when called with a :server argument) I needed to change Access and Launch options in dcomcnfg's Default Security tab. But more is needed for the receiver callback: without something else I get ``Access denied'' on the GetIDsOfNames call from the worker back to the supervisor when running on a different machine (on the same machine, even when called with :server there is no problem). A very dirty workaround is to change the Default Authentication Level in the Default Properties tab to (None) instead of Connect. I also ran the supervisor as Administrator, but I'm not sure that was necessary.

COM Basics

<package specification>= (U-> U->)
(defpackage "WIN32-COM" (:nicknames "COM") (:use "XLISP"))
(in-package "WIN32-COM")

*

<COM basics>= (U->)
(let ((major 3)
      (minor 52)
      (subminor 16))
  (unless (or (> system:xls-major-release major)
              (and (= system:xls-major-release major)
                   (> system:xls-minor-release minor))
              (and (= system:xls-major-release major)
                   (= system:xls-minor-release minor)
                   (>= system:xls-subminor-release subminor)))
    (error "COM support requires at least version ~d.~d.~d"
           major minor subminor)))

(require "win32")
(provide "win32com")
<package specification>

(defvar *com-library*)
(wrap:library-load *com-library*)

(wrap:c-lines "#include \"comutil.h\"")
<debugging support>
<C type declarations>
<basic constants>
<error constants>
<server constants>
<dispatch constants>
<type library constants>
<type information constants>
<support utilities>
<initialization and termination>
<GUID and CLSID functions>
<locale support>
<error handling>
<interfaces>

Debugging Support

<debugging support>= (U->)
(defparameter *com-debug* nil)

(defun debug-print (fmt &rest args)
  (when *com-debug* (apply #'format *debug-io* fmt args)))

Defines *com-debug*, debug-print (links are to index).

Initialization and Termination

<initialization and termination>= (U->) [D->]
(wrap:std-com-function co-initialize "CoInitialize" ((:cptr "void" t)))
(wrap:c-function co-uninitialize "CoUninitialize" () :void)

Defines co-initialize, co-uninitialize (links are to index).

**** use an internal weak hash table here.

<initialization and termination>+= (U->) [<-D->]
(defparameter *com-initialized* nil)
(defparameter *com-exit-handlers* nil)

Defines *com-exit-handlers*, *com-initialized* (links are to index).

<initialization and termination>+= (U->) [<-D->]
(defun com-embedding ()
  (if (find "-Embedding" *command-line* :test #'string=) t nil))

Defines com-embedding (links are to index).

**** This locks the server process if the embedding flag isn't there. I'm not unlocking it so unloading does not kill the process.

<initialization and termination>+= (U->) [<-D->]
(defun uninitialize-com ()
  (when *com-initialized*
    (revoke-all-active-objects)
    (revoke-all-class-factories)
    (disconnect-all-event-listeners)
    (disconnect-all-servers)
    (run-com-exit-handlers)
    (co-uninitialize)
    (setf *com-initialized* nil)
    (setf *com-exit-handlers* nil)))

(defun initialize-com ()
  (unless *com-initialized*
    (co-initialize nil)
    (unless (com-embedding) (add-ref-server-process))
    (system:add-exit-function #'uninitialize-com)
    (setf *com-initialized* t)
    (setf *com-exit-handlers* (make-hash-table))))

Defines initialize-com, uninitialize-com (links are to index).

For now, just put initialize-com call in each possible starting point. Once threads are added this might need to be done very differently.

<initialization and termination>+= (U->) [<-D->]
(defun register-com-exit-handler (object handler)
  (let ((key (pointer-address (address-of object)))
        (val (cons (make-weak-box object) handler)))
    (setf (gethash key *com-exit-handlers*) val)))

(defun unregister-com-exit-handler (object)
  (let ((key (pointer-address (address-of object))))
    (remhash key *com-exit-handlers*)))

(defun run-com-exit-handlers ()
  (unwind-protect
      (maphash #'(lambda (key val)
                   (let ((object (weak-box-value (car val)))
                         (fun (cdr val)))
                     (when object (ignore-errors (funcall fun object)))))
               *com-exit-handlers*)
    (clrhash *com-exit-handlers*)))

Defines register-com-exit-handler, run-com-exit-handlers, unregister-com-exit-handler (links are to index).

<initialization and termination>+= (U->) [<-D]
(defun unload-com ()
  (uninitialize-com)
  (let ((lib *com-library*))
    (when lib
      (shlib:close-shared-library lib)
      (setf *com-library* nil))))

Defines unload-com (links are to index).

GUID and CLSID Functions

<GUID and CLSID functions>= (U->) [D->]
(export '(<GUID and CLSID exports>))

GUID Representation

<GUID and CLSID functions>+= (U->) [<-D->]
(defstruct (guid (:constructor new-guid (data hash-value))
                 (:print-function (lambda (guid stream d)
                                    (declare (ignore d))
                                    (format stream "#<GUID ~a>"
                                            (guid-string guid)))))
  data string-cache hash-value)

Defines guid, guid-data, guid-hash-value, guid-p (links are to index).

<GUID and CLSID exports>= (<-U) [D->]
guid guid-p

*

<GUID and CLSID functions>+= (U->) [<-D->]
(defun guid-string (guid)
  (let ((cache (guid-string-cache guid)))
    (if cache
        cache
      (let ((string (guid-data-to-string (guid-data guid))))
        (setf (guid-string-cache guid) string)
        string))))

Defines guid-string (links are to index).

<GUID and CLSID exports>+= (<-U) [<-D->]
guid-string

*

<GUID and CLSID functions>+= (U->) [<-D->]
(wrap:c-pointer "GUID" (:make make-guid-data))

Defines make-guid-data (links are to index).

Managing Representation Uniqueness

<GUID and CLSID functions>+= (U->) [<-D->]
(wrap:c-lines "
LVAL GetGuidHash(GUID *pg)
{
  LVAL val, shift, arg;
  unsigned char *p = (unsigned char *) pg;
  int i;

  xlstkcheck(3);
  xlsave(val);
  xlsave(shift);
  xlsave(arg);
  shift = cvfixnum(8);

  val = cvfixnum(p[0]);
  for (i = 1; i < sizeof(GUID); i++) {
    arg = cvfixnum(p[i]);
    val = xlcallsubr2(xash, val, shift);
    val = xlcallsubr2(xadd, val, arg);
  }
  xlpopn(3);
  return val;
}")
(wrap:c-function guid-data-hash-value "GetGuidHash" ((:cptr "GUID")) :lval)

Defines GetGuidHash, guid-data-hash-value (links are to index).

;;***** using pointer wrappers:

<Lisp version of guid-data-hash-value>=
(defun guid-data-hash-value (data)
  (let ((ucd (wrapptrs:cast-c-uchar (guid-data g)))
        (val 0))
    (dotimes (i 16 val)
      (setf val (+ (ash val 8) (wrapptrs:get-c-uchar ucd i))))))

Defines guid-data-hash-value (links are to index).

<GUID and CLSID functions>+= (U->) [<-D->]
(defvar *guids* (make-hash-table))

(defun make-guid (data)
  (let* ((hash-value (guid-data-hash-value data))
         (guid (gethash hash-value *guids*)))
    (if guid
        guid
      (let ((new-guid (new-guid data hash-value)))
        (setf (gethash hash-value *guids*) new-guid)
        new-guid))))

Defines *guids*, make-guid (links are to index).

String Representation

<GUID and CLSID functions>+= (U->) [<-D->]
(defun clsid-from-string (name)
  (let* ((data (make-guid-data))
         (wname (string-to-wide-string name)))
    (base-clsid-from-string wname data)
    (make-guid data)))

(wrap:std-com-function base-clsid-from-string "CLSIDFromString"
                       ((:cptr "WCHAR") (:cptr "GUID")))

Defines base-clsid-from-string, clsid-from-string (links are to index).

<GUID and CLSID exports>+= (<-U) [<-D->]
clsid-from-string

*

<GUID and CLSID functions>+= (U->) [<-D->]
(defun guid-from-string (name)
  (let* ((data (make-guid-data))
         (wname (string-to-wide-string name)))
    (base-iid-from-string wname data)
    (make-guid data)))

(wrap:std-com-function base-iid-from-string "IIDFromString"
                       ((:cptr "WCHAR") (:cptr "GUID")))

Defines base-iid-from-string, guid-from-string (links are to index).

<GUID and CLSID exports>+= (<-U) [<-D->]
guid-from-string

*

<GUID and CLSID functions>+= (U->) [<-D->]
(defun guid-data-to-string (data)
  (let* ((wsize 80)
         (wstring (make-wide-string wsize))
         (res (string-from-guid2 data wstring wsize)))
    (when (= 0 res) (error "buffer to small for GUID conversion"))
    (wide-string-to-string wstring)))

(wrap:c-function string-from-guid2 "StringFromGUID2"
                 ((:cptr "GUID") (:cptr "WCHAR" t) :integer) :integer)

Defines guid-data-to-string, string-from-guid2 (links are to index).

ProgID Lookup

<GUID and CLSID functions>+= (U->) [<-D->]
;;;***** Need to do lookup across the network
(defun clsid-from-progid (name)
  (let* ((clsid (make-guid-data))
         (wname (string-to-wide-string name)))
    (base-clsid-from-progid wname clsid)
    (make-guid clsid)))

(wrap:std-com-function base-clsid-from-progid "CLSIDFromProgID"
                       ((:cptr "WCHAR") (:cptr "GUID")))

Defines base-clsid-from-progid, clsid-from-progid (links are to index).

<GUID and CLSID exports>+= (<-U) [<-D->]
clsid-from-progid

*

<GUID and CLSID functions>+= (U->) [<-D->]
;;**** not a perfect test but it'll do
(defun guid-string-p (x)
  (and (stringp x) (= (length x) 38) (eql (char x 0) #\{)))

(defun find-clsid (cls-spec)
  (etypecase cls-spec
             (guid cls-spec)
             ((satisfies guid-string-p) (guid-from-string cls-spec))
             (string (clsid-from-progid cls-spec))))

Defines find-clsid, guid-string-p (links are to index).

Creating New GUIDs

<GUID and CLSID functions>+= (U->) [<-D->]
(defun create-guid ()
  (let ((guid (make-guid-data)))
    (co-create-guid guid)
    (make-guid guid)))

(wrap:std-com-function co-create-guid "CoCreateGuid" ((:cptr "GUID")))

Defines co-create-guid, create-guid (links are to index).

<GUID and CLSID exports>+= (<-U) [<-D]
create-guid

Standard Interface IDs

<GUID and CLSID functions>+= (U->) [<-D->]
(defun get-std-iid (name)
  (let ((data (make-guid-data)))
    (unless (base-get-std-iid name data) (error "can't find IID_~a" name))
    (make-guid data)))

Defines get-std-iid (links are to index).

<GUID and CLSID functions>+= (U->) [<-D]
(wrap:c-lines "
#define CHECK_STD_IID(n,t,p) do { if (strcmp(n,#t)==0) { *p=IID_##t; return TRUE; } } while (0)
static BOOL GetStdIID(char *name, GUID *pguid)
{
  CHECK_STD_IID(name, NULL, pguid);
  CHECK_STD_IID(name, IUnknown, pguid);
  CHECK_STD_IID(name, IDispatch, pguid);
  CHECK_STD_IID(name, ITypeInfo, pguid);
  CHECK_STD_IID(name, ITypeLib, pguid);
  CHECK_STD_IID(name, IEnumVARIANT, pguid);
  CHECK_STD_IID(name, IConnectionPointContainer, pguid);
  CHECK_STD_IID(name, IClassFactory, pguid);
  CHECK_STD_IID(name, IProvideClassInfo, pguid);
  return FALSE;
}
#undef CHECK_STD_IID
")
(wrap:c-function base-get-std-iid "GetStdIID" (:string (:cptr "GUID")) :bool)

Defines base-get-std-iid, CHECK_STD_IID, GetStdIID (links are to index).

Locale Support

<locale support>= (U->) [D->]
(wrap:declare-c-type lcid "LCID" :unsigned)

Defines lcid (links are to index).

**** export this?

<locale support>+= (U->) [<-D->]
(wrap:c-constant LOCALE_SYSTEM_DEFAULT "LOCALE_SYSTEM_DEFAULT" :unsigned)

Defines LOCALE_SYSTEM_DEFAULT (links are to index).

**** get rid of function now that variable works?? **** export variable?

<locale support>+= (U->) [<-D]
(defvar *com-locale* LOCALE_SYSTEM_DEFAULT)
(defun com-locale () *com-locale*)

Defines com-locale (links are to index).

Error Handling

<error handling>= (U->)
(export '(<error handling exports>))
<HRESULT decoding>
<EXCEPINFO decoding>
<signaling COM errors>

HRESULT Decoding

<C type declarations>= (U->) [D->]
(wrap:declare-c-type hresult "HRESULT" :unsigned)

Defines hresult (links are to index).

<HRESULT decoding>= (<-U) [D->]
(wrap:c-function hresult-failed "FAILED" (hresult) :bool)

Defines hresult-failed (links are to index).

<HRESULT decoding>+= (<-U) [<-D->]
(wrap:c-lines "
static LVAL GetHresultMessage(HRESULT hr)
{
  char *msg = NULL;
  LVAL val;
  DWORD count;

  count = FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER |
                        FORMAT_MESSAGE_FROM_SYSTEM |
                        FORMAT_MESSAGE_IGNORE_INSERTS,
                        NULL, hr, LOCALE_SYSTEM_DEFAULT,
                        (LPTSTR)&msg, 0, NULL);
  val = count > 0 && msg != NULL ? cvstring(msg) : NIL;
  if (msg != NULL) LocalFree(msg);
  return val;
}")

(wrap:c-function base-hresult-to-string "GetHresultMessage" (hresult) :lval)

Defines base-hresult-to-string, GetHresultMessage (links are to index).

<HRESULT decoding>+= (<-U) [<-D]
(defun hresult-to-string (hr)
  (let ((hrstr (base-hresult-to-string hr)))
    (if hrstr
        (string-right-trim '(#\newline #\return) hrstr)
      "unknown OLE error")))

Defines hresult-to-string (links are to index).

EXCEPINFO Decoding

<EXCEPINFO decoding>= (<-U)
;;**** doesn't run the function pointer if it is there (is it ever??)
(wrap:c-pointer "EXCEPINFO"
                (:get excepinfo-wcode "wCode" :unsigned)
                (:get excepinfo-scode "scode" :unsigned)
                (:get excepinfo-source "bstrSource" (:cptr "WCHAR"))
                (:get excepinfo-description "bstrDescription" (:cptr "WCHAR"))
                (:get excepinfo-help-file "bstrHelpFile" (:cptr "WCHAR"))
                (:get excepinfo-help-context "dwHelpContext" :unsigned))

Defines excepinfo-description, excepinfo-help-context, excepinfo-help-file, excepinfo-scode, excepinfo-source, excepinfo-wcode (links are to index).

Signaling COM Errors

<error constants>= (U->)
(wrap:c-constant DISP_E_EXCEPTION "DISP_E_EXCEPTION" :unsigned)

Defines DISP_E_EXCEPTION (links are to index).

<signaling COM errors>= (<-U) [D->]
(define-condition com-error (error)
  ((hresult :reader com-error-hresult :initarg :hresult)
   (guid :reader com-error-guid :initarg :guid)
   (source :reader com-error-source :initarg :source)
   (description :reader com-error-description :initarg :description)
   (help-file :reader com-error-help-file :initarg :help-file)
   (help-context :reader com-error-help-context :initarg :help-context))
  (:report (lambda (cond stream)
             (let ((hr (com-error-hresult cond))
                   (src (com-error-source cond))
                   (desc (com-error-description cond)))
               (let ((hrstr (if desc desc (hresult-to-string hr))))
                 (format stream "~@[~a: ~]~a" src hrstr))))))

Defines com-error, com-error-description, com-error-guid, com-error-help-context, com-error-help-file, com-error-hresult (links are to index).

<error handling exports>= (<-U)
com-error com-error-guid com-error-hresult
com-error-description com-error-help-file com-error-help-context

;;***** need server to fill in Source sensibly

<signaling COM errors>+= (<-U) [<-D->]
(defun make-idispatch-exception (hr name excep)
  (flet ((bstr2str (ws)
           (when ws (prog1 (wide-string-to-string ws) (free-bstr ws)))))
    (let ((scode (excepinfo-scode excep))
          (source (bstr2str (excepinfo-source excep)))
          (desc (bstr2str (excepinfo-description excep)))
          (help (bstr2str (excepinfo-help-file excep)))
          (helpctxt (excepinfo-help-context excep)))
      (make-condition 'com-error
                      :hresult (if (hresult-failed scode) scode hr)
                      :source (if source source name)
                      :description (cond
                                    (desc desc)
                                    ((hresult-failed scode)
                                     (hresult-to-string scode))
                                    (t "unknown exception"))
                      :help-file help
                      :help-context helpctxt))))

Defines make-idispatch-exception (links are to index).

<signaling COM errors>+= (<-U) [<-D->]
(defun make-std-com-exception (hr name)
  (let ((hrstr (hresult-to-string hr)))
    (make-condition 'com-error :hresult hr :source name :description hrstr)))

Defines make-std-com-exception (links are to index).

**** Should try to use Rich Error Info if in a method call. This means handling method calls and functions separately; method calls need to get the interface that produced the error so thay can call GetErrorInfo or whatever it is called.

<signaling COM errors>+= (<-U) [<-D->]
(defun raise-com-error (hr &optional name excep)
  (error (if (and excep (= hr DISP_E_EXCEPTION))
             (make-idispatch-exception hr name excep)
           (make-std-com-exception hr name))))

Defines raise-com-error (links are to index).

<signaling COM errors>+= (<-U) [<-D]
(wrap:c-callback "RaiseComError" raise-com-error
                 (hresult :string (:cptr "EXCEPINFO")) :void
                 :static nil)

Defines RaiseComError (links are to index).

<error signaling support declarations>= (U->)
void RaiseComError(HRESULT hr, char * fun, EXCEPINFO *e);

Defines RaiseComError (links are to index).

Interfaces

<interfaces>= (U->)
(export '(<interface exports>))
<interface representation>
<finding and registering interfaces>
<interface references>
<declaring interfaces>
<standard interfaces>

Interface Representation

<interface representation>= (<-U)
(defstruct (interface
            (:constructor new-interface (name cname constructor caster iid))
            (:print-function (lambda (intf stream d)
                               (declare (ignore d))
                               (format stream "#<~a ~a>"
                                       (type-of intf)
                                       (interface-cname intf)))))
  name cname constructor caster iid display)

Defines interface, interface-caster, interface-cname, interface-constructor, interface-display, interface-iid, interface-name, interface-p (links are to index).

<interface exports>= (<-U) [D->]
interface interface-p interface-name interface-cname
interface-iid

Finding and Registering Interfaces

<finding and registering interfaces>= (<-U) [D->]
(defvar *interfaces* (make-hash-table))

(defun add-interface (interface)
  (let ((name (interface-name interface))
        (iid (interface-iid interface)))
    (when (gethash name *interfaces*)
      (warn "interface ~s is being redefined" name))
    (when (gethash iid *interfaces*)
      (warn "interface with IID ~s is being redefined" iid))
    (setf (gethash name *interfaces*) interface)
    (setf (gethash iid *interfaces*) interface)))    

Defines add-interface, *interfaces* (links are to index).

**** could also search by cname

<finding and registering interfaces>+= (<-U) [<-D]
(defun find-interface (intfspec)
  (etypecase intfspec
             (interface intfspec)
             (guid (gethash intfspec *interfaces*))
             (symbol (gethash intfspec *interfaces*))
             (string (gethash (guid-from-string intfspec) *interfaces*))))

(defun find-interface-iid (intfspec)
  (if (guid-p intfspec)
      intfspec
    (interface-iid (find-interface intfspec))))

Defines find-interface, find-interface-iid (links are to index).

<interface exports>+= (<-U) [<-D->]
find-interface find-interface-iid

Interface References

<interface references>= (<-U) [D->]
(defstruct (com-ref
            (:print-function (lambda (ref stream d)
                               (declare (ignore d))
                               (format stream "#<~s>" (type-of ref)))))
  <com-ref slots>)

Defines com-ref, com-ref-address, com-ref-interface-display, com-ref-p (links are to index).

<com-ref slots>= (<-U U->)
address interface-display

*

<interface references>+= (<-U) [<-D->]
(defun make-com-ref-pointer-accessor (intf)
  (let* ((name (interface-cname intf))
         (type (lookup-pointer-type name))
         (index (- (length (interface-display intf)) 1)))
    (lambda (ref)
      (let ((idisp (com-ref-interface-display ref)))
        (unless (and (< index (length idisp)) (eq (aref idisp index) intf))
          (error "~a is not a reference of type ~a" ref type))
        (base-cast-pointer type (com-ref-address ref))))))

Defines make-com-ref-pointer-accessor (links are to index).

**** export this??? **** change name???

<interface references>+= (<-U) [<-D->]
(defun release-reference (ref)
  (let ((ptr (iunknown-pointer ref)))
    (when ptr
      (disconnect-event-listeners ref)
      (setf (com-ref-address ref) nil)
      (debug-print "Unregistering ... ")
      (unregister-com-exit-handler ref)
      (debug-print "Releasing ~a ... " (type-of ref))
      (base-iunknown-release ptr)
      (debug-print "done~%"))))

Defines release-reference (links are to index).

**** change name???

<interface references>+= (<-U) [<-D]
(defun make-reference (intfspec pointer &rest args)
  (if pointer
      (let ((intf (find-interface intfspec)))
        (unless intf (error "interface ~s is not declared" intfspec))
        (let* ((idisp (interface-display intf))
               (cptr (funcall (interface-caster intf) pointer))
               (ref (apply (interface-constructor intf) cptr idisp args)))
          (system:cptr-protect cptr ref)
          (register-com-exit-handler ref #'release-reference)
          (system:register-finalizer ref #'release-reference)
          ref))
    nil))

Defines make-reference (links are to index).

Declaring Interfaces

<declaring interfaces>= (<-U) [D->]
(defvar *base-interface*)

(defmacro declare-interface (first &rest more)
  (if (consp first)
      `(declare-interface-1 ,first ,@more)
    `(declare-interface-1 (,first) ,@more)))

(defmacro declare-interface-1 ((cname &key name include print iid) &rest slots)
  (let ((name (if name name (intern (string-upcase cname)))))
    (when (string= cname "IUnknown") (setf *base-interface* name))
    (let* ((constr (intern (concatenate 'string "NEW-" (string name))))
           (parent (cond
                    (include include)
                    ((eq name *base-interface*) 'com-ref)
                    (t *base-interface*)))
           (mods `((:include ,parent)
                   (:constructor ,constr (<com-ref slots>))))
           (iid-name (intern (concatenate 'string
                                          "IID_" (string-upcase cname)))))
      (when print (push `(:print-function ,print) mods))
      `(progn
         (defstruct (,name ,@mods) ,@slots)
         (add-interface (make-interface ',name ,cname #',constr ,iid ',parent))
         (defconstant ,iid-name (find-interface-iid ',name))
         ',name))))

Defines *base-interface*, declare-interface, declare-interface-1 (links are to index).

**** separate out definition of pointer accessor function from creation of function (put function in interface as slot, put assignment to symbol into macro)???

<declaring interfaces>+= (<-U) [<-D]
(defun make-interface (name cname constr iid parent)
  (let* ((guid (etypecase iid
                          (null (get-std-iid cname))
                          (string (guid-from-string iid))
                          (guid iid)))
         (cast (make-pointer-caster cname))
         (intf (new-interface name cname constr cast guid))
         (pdisp (if (eq parent 'com-ref)
                    nil
                  (interface-display (find-interface parent))))
         (ptrname (intern (concatenate 'string (string name) "-POINTER"))))
    (setf (interface-display intf) (concatenate 'vector pdisp (list intf)))
    (setf (symbol-function ptrname) (make-com-ref-pointer-accessor intf))
    intf))

Defines make-interface (links are to index).

Some Standard Interfaces

<standard interfaces>= (<-U) [D->]
(declare-interface "IUnknown")

Defines IID_IUNKNOWN, iunknown (links are to index).

<interface exports>+= (<-U) [<-D->]
iunknown IID_IUNKNOWN

**** Don't declare this as interface since it doesn't make sense and would mess up the null type.

<standard interfaces>+= (<-U) [<-D->]
(defconstant IID_NULL (get-std-iid "NULL"))

Defines IID_NULL (links are to index).

<interface exports>+= (<-U) [<-D->]
IID_NULL

*

<standard interfaces>+= (<-U) [<-D->]
(declare-interface ("IDispatch"
                    :print (lambda (ref stream d)
                             (let ((info-name (idispatch-info-name ref))
                                   (type (type-of ref)))
                               (if info-name
                                   (format stream "#<~s ~a>" type info-name)
                                 (format stream "#<~s>" type)))))
  (info-name-cache :empty))

(defun idispatch-info-name (ref)
  (let ((cache (idispatch-info-name-cache ref)))
    (if (eq cache :empty)
        (let* ((info (idispatch-type-info ref))
               (name (when info (itypeinfo-name info))))
          (setf (idispatch-info-name-cache ref) name)
          name)
      cache)))

Defines idispatch, idispatch-info-name, IID_IDISPATCH (links are to index).

<interface exports>+= (<-U) [<-D->]
idispatch IID_IDISPATCH

*

<standard interfaces>+= (<-U) [<-D->]
(declare-interface ("ITypeInfo"
                    :print (lambda (ref stream d)
                             (declare (ignore d))
                             (let ((type (type-of ref))
                                   (name (itypeinfo-name ref)))
                               (format stream "#<~a~@[ ~a~]>" type name)))))

;;**** avoid lookup??
(defun wrap-itypeinfo (ptr)
  (make-reference 'itypeinfo ptr))

Defines IID_ITypeInfo, itypeinfo, wrap-itypeinfo (links are to index).

<interface exports>+= (<-U) [<-D->]
itypeinfo IID_ITypeInfo

*

<standard interfaces>+= (<-U) [<-D->]
(declare-interface ("ITypeLib"
                    :print (lambda (ref stream d)
                             (declare (ignore d))
                             (let ((type (type-of ref))
                                   (name (itypelib-name ref)))
                               (format stream "#<~a~@[ ~a~]>" type name)))))

;;**** avoid lookup??
(defun wrap-itypelib (ptr)
  (make-reference 'itypelib ptr))

Defines IID_ITypeLib, itypelib, wrap-itypelib (links are to index).

<interface exports>+= (<-U) [<-D]
itypelib IID_ITypeLib

**** flesh these out, add exports; maybe add a few more.

<standard interfaces>+= (<-U) [<-D]
(declare-interface "IClassFactory")
(declare-interface "IConnectionPointContainer")
(declare-interface "IEnumVARIANT")

Client Support

<COM client support>= (U->)
(export '(<client support exports>))
<creating object references>
<IUnknown interface>
<IDispatch interface>
<automation support>
<variant type conversion>

Creating Object References

<creating object references>= (<-U)
<creating new instances>
<binding to objects>
<accessing active objects>
<returning object references>

Creating New Instances

<C type declarations>+= (U->) [<-D->]
(wrap:declare-c-type dword "DWORD" :unsigned)

Defines dword (links are to index).

<creating new instances>= (<-U) [D->]
(wrap:std-com-function co-create-instance "CoCreateInstance"
                       ((:cptr "GUID") (:cptr "IUnknown" t)
                        dword (:cptr "GUID")
                        (:value (:cptr "void"))))

(wrap:c-lines "
static HRESULT CreateRemoteInstance(CLSID *cid, IUnknown *pouter, DWORD cntxt,
                                    WCHAR *server, IID *iid, void **ppunk)
{
  HRESULT hr;
  MULTI_QI mqi;
  COSERVERINFO csi;

  if (pCoCreateInstanceEx == NULL) xlfail(\"DCOM not available\");

  memset(&mqi, 0, sizeof(MULTI_QI));
  memset(&csi, 0, sizeof(COSERVERINFO));
  mqi.pIID = iid;
  csi.pwszName = server;
  *ppunk = NULL;
  hr = pCoCreateInstanceEx(cid, pouter, cntxt, &csi, 1, &mqi);
  *ppunk = mqi.pItf;
  return FAILED(hr) ? hr : mqi.hr;
}")

(wrap:std-com-function create-remote-instance "CreateRemoteInstance"
                 ((:cptr "GUID") (:cptr "IUnknown" t) dword
                  (:cptr "WCHAR") (:cptr "GUID") 
                  (:value (:cptr "void"))))

Defines co-create-instance, create-remote-instance, CreateRemoteInstance (links are to index).

**** test remote version!! **** Why does DAO.DBEngine.35 return an Unknown OLE Error? **** For DLL components, do I need to check for CanUnload??

<creating new instances>+= (<-U) [<-D]
(defun base-create-object (clsid outer cntxt server)
  (let ((iid (guid-data IID_IUnknown)))
    (system:without-interrupts
     (make-reference
      IID_IUnknown
      (if server
          (let ((wserver (string-to-wide-string server)))
            (create-remote-instance clsid outer cntxt wserver iid))
        (co-create-instance clsid outer cntxt iid))))))

(defun create-object (cls-spec &key
                               outer
                               (context :server)
                               (interface 'idispatch)
                               server)
  (initialize-com)
  (let* ((clsid (guid-data (find-clsid cls-spec)))
         (pouter (if outer (iunknown-pointer outer) nil))
         (cntxt <translate keyword to CLSCTX value>)
         (unk (base-create-object clsid pouter cntxt server)))
    (query-interface unk interface)))

Defines base-create-object, create-object (links are to index).

<client support exports>= (<-U) [D->]
create-object

**** move this to the right place The registration function is given the context to use as a keyword. The possible keywords are :inproc, :local and :server; these are translated to the C level as

<translate keyword to CLSCTX value>= (<-U U->)
(ecase context
       (:inproc CLSCTX_INPROC_SERVER)
       (:local (logior CLSCTX_INPROC_SERVER
                       CLSCTX_LOCAL_SERVER))
       (:server CLSCTX_SERVER))

Several constants are used to specify the registration context.

<server constants>= (U->)
(wrap:c-constant CLSCTX_INPROC_SERVER "CLSCTX_INPROC_SERVER" :unsigned)
(wrap:c-constant CLSCTX_LOCAL_SERVER "CLSCTX_LOCAL_SERVER" :unsigned)
(wrap:c-constant CLSCTX_SERVER "CLSCTX_SERVER" :unsigned)

Defines CLSCTX_INPROC_SERVER, CLSCTX_LOCAL_SERVER, CLSCTX_SERVER (links are to index).

Binding To Objects

<binding to objects>= (<-U) [D->]
(wrap:c-lines "
static HRESULT MyGetObject(WCHAR *name, REFIID iid, void **ppval)
{
  HRESULT hr;
  IBindCtx *pbind = NULL;
  IMoniker *pmon = NULL;
  DWORD len;

  hr = CreateBindCtx(0, &pbind);
  if (SUCCEEDED(hr)) {
    hr = MkParseDisplayName(pbind, name, &len, &pmon);
    if (SUCCEEDED(hr)) {
      hr = IMoniker_BindToObject(pmon, pbind, NULL, iid, ppval);
      IUnknown_Release(pmon);
    }
    IUnknown_Release(pbind);
  }
  return hr;
}")
(wrap:std-com-function base-get-object "MyGetObject"
                       ((:cptr "WCHAR") (:cptr "GUID")
                        (:value (:cptr "void"))))

Defines base-get-object, MyGetObject (links are to index).

<binding to objects>+= (<-U) [<-D]
(defun get-object (name &optional (interface 'idispatch))
  (initialize-com)
  (let ((iid-data (guid-data (find-interface-iid interface)))
        (wname (string-to-wide-string name)))
    (system:without-interrupts
     (make-reference interface (base-get-object wname iid-data)))))

Defines get-object (links are to index).

<client support exports>+= (<-U) [<-D->]
get-object

Accessing Active Objects

<accessing active objects>= (<-U)
(wrap:std-com-function base-get-active-object "GetActiveObject"
                       ((:cptr "GUID") (:cptr "void" t)
                        (:value (:cptr "IUnknown"))))

(defun get-active-object (cls-spec &optional (interface 'idispatch))
  (initialize-com)
  (let* ((clsid (guid-data (find-clsid cls-spec)))
         (unk (system:without-interrupts
               (make-reference 'iunknown (base-get-active-object clsid nil)))))
    (query-interface unk interface)))

Defines base-get-active-object, get-active-object (links are to index).

<client support exports>+= (<-U) [<-D->]
get-active-object

Returning Object References

<returning object references>= (<-U) [D->]
;;**** trap errors, return NULL?
;;**** should this be released before close?
(wrap:c-callback "IDispatch2Lisp" wrap-idispatch ((:cptr "IDispatch")) :lval
                 :static nil
                 :interrupts-allow nil)

;;;**** avoid the lookup here??
(defun wrap-idispatch (ref)
  (make-reference 'idispatch ref))

Defines IDispatch2Lisp (links are to index).

<type conversion declarations>= (U->) [D->]
LVAL IDispatch2Lisp(IDispatch *pdisp);

**** Issue: exit can happen inside unwind-protect--ought to throw out of current context to exit point.

**** move someplace else?

<returning object references>+= (<-U) [<-D]
;;**** avoid lookup??
(defun wrap-iunknown (ref)
  (make-reference 'iunknown ref))

(wrap:c-callback "IUnknown2Lisp" wrap-iunknown ((:cptr "IUnknown")) :lval
                 :static nil
                 :interrupts-allow nil)

Defines IUnknown2Lisp, wrap-iunknown (links are to index).

<type conversion declarations>+= (U->) [<-D->]
LVAL IUnknown2Lisp(IUnknown *punk);

Defines IUnknown2Lisp (links are to index).

The IUnknown Interface

<IUnknown interface>= (<-U) [D->]
(wrap:c-lines "
static HRESULT BaseQueryInterface(IUnknown *punk, REFIID riid, void **val,
                                  BOOL not_found_is_error)
{
  HRESULT hr = IUnknown_QueryInterface(punk, riid, val);
  if (hr ==  E_NOINTERFACE && ! not_found_is_error) {
    *val = NULL;
    return S_OK;
  }
  else return hr;
}")

(wrap:std-com-function base-query-interface "BaseQueryInterface"
                       ((:cptr "IUnknown") (:cptr "GUID")
                        (:value (:cptr "void")) bool))
#|
(wrap:c-function base-iunknown-addref "IUnknown_AddRef"
                 ((:cptr "IUnknown")) ulong)
|#

(wrap:c-function base-iunknown-release "IUnknown_Release"
                 ((:cptr "IUnknown")) ulong)

Defines base-iunknown-release, base-query-interface, BaseQueryInterface (links are to index).

<IUnknown interface>+= (<-U) [<-D]
(defun query-interface (ref iidspec &optional (not-found nil nfsupp))
  (system:without-interrupts
   (let* ((ptr (iunknown-pointer ref))
          (iid (find-interface-iid iidspec))
          (iid-data (guid-data iid))
          (nptr (base-query-interface ptr iid-data (not nfsupp))))
     (if nptr (make-reference iid nptr) not-found))))

Defines query-interface (links are to index).

<C type declarations>+= (U->) [<-D->]
(wrap:declare-c-type bool "BOOL" :bool)
(wrap:declare-c-type ulong "ULONG" :unsigned)

Defines bool, ulong (links are to index).

<client support exports>+= (<-U) [<-D->]
query-interface release-reference

The IDispatch Interface

<IDispatch interface>= (<-U)
<IDispatch type information>
<dispatch IDs>
<method invokation>

Type Information

<IDispatch type information>= (<-U)
(wrap:std-com-function base-idispatch-get-type-info-count
                       "IDispatch_GetTypeInfoCount"
                       ((:cptr "IDispatch") (:value dword)))

(wrap:std-com-function base-idispatch-get-type-info "IDispatch_GetTypeInfo"
                       ((:cptr "IDispatch") :unsigned lcid
                        (:value (:cptr "ITypeInfo"))))

(defun idispatch-type-info (ref &optional
                                (index 0) (lcid LOCALE_SYSTEM_DEFAULT))
  (let ((pdisp (idispatch-pointer ref)))
    (values
     (ignore-errors
      (system:without-interrupts
       (when (/= 0 (base-idispatch-get-type-info-count pdisp))
         (make-reference 'itypeinfo
                         (base-idispatch-get-type-info pdisp index lcid))))))))

Defines idispatch-type-info (links are to index).

<client support exports>+= (<-U) [<-D->]
idispatch-type-info

Dispatch IDs

<dispatch constants>= (U->) [D->]
(wrap:c-constant DISPID_VALUE "DISPID_VALUE" :unsigned)

*

<C type declarations>+= (U->) [<-D->]
(wrap:declare-c-type dispid "DISPID" :unsigned)

*

<dispatch IDs>= (<-U) [D->]
(wrap:c-pointer "DISPID"
                (:make make-dispid)
                (:get get-dispid nil dispid)
                (:set set-dispid nil dispid))

*

<dispatch IDs>+= (<-U) [<-D->]
(wrap:c-pointer (:cptr "WCHAR")
                (:make make-wide-string-array)
                (:get get-cptr-wchar nil (:cptr "WCHAR")))

(wrap:c-lines "
static void set_cptr_wchar(WCHAR **pw, WCHAR *w, int off) {
  pw[off] = w;
}")
(wrap:c-function set-cptr-wchar "set_cptr_wchar"
                 ((:cptr (:cptr "WCHAR")) (:cptr "WCHAR") :integer) :void)

cptr-protect pushes each new wide string onto the array's protection list.

<dispatch IDs>+= (<-U) [<-D->]
(defun names-to-wide-string-array (names)
  (let ((wnames (make-wide-string-array (length names)))
        (i 0))
    (dolist (s names wnames)
      (let ((ws (string-to-wide-string (string s))))
        (system:cptr-protect wnames ws)
        (set-cptr-wchar wnames ws i)
        (incf i)))))

*

<dispatch IDs>+= (<-U) [<-D->]
(defun dispids-to-list (dispids n)
  (let ((val nil))
    (dotimes (i n (nreverse val))
      (push (get-dispid dispids i) val))))

*

<dispatch IDs>+= (<-U) [<-D->]
(wrap:std-com-function base-idispatch-ids-of-names "IDispatch_GetIDsOfNames"
                       ((:cptr "IDispatch") (:cptr "GUID")
                        (:cptr (:cptr "WCHAR")) :unsigned lcid
                        (:cptr "DISPID")))

Defines base-idispatch-ids-of-names (links are to index).

**** need to do some caching here??

<dispatch IDs>+= (<-U) [<-D]
(defun idispatch-ids-of-names (object name &optional keys)
  (if name
      (let* ((names (cons name keys))
             (n (length names))
             (wnames (names-to-wide-string-array names))
             (dispids (make-dispid n))
             (disp (idispatch-pointer object))
             (locale (com-locale))
             (iid-data (guid-data IID_NULL)))
        (base-idispatch-ids-of-names disp iid-data wnames n locale dispids)
        (let ((val (dispids-to-list dispids n)))
          (values (first val) (rest val))))
    (if keys
        (error "can't have named arguments with default mehtod")
      DISPID_VALUE)))

*

<client support exports>+= (<-U) [<-D->]
idispatch-ids-of-names

Method Invokation

<dispatch constants>+= (U->) [<-D->]
(wrap:c-constant DISPID_PROPERTYPUT "DISPID_PROPERTYPUT" :unsigned)
(wrap:c-constant DISPATCH_PROPERTYPUT "DISPATCH_PROPERTYPUT" :unsigned)
(wrap:c-constant DISPATCH_PROPERTYPUTREF "DISPATCH_PROPERTYPUTREF" :unsigned)
(wrap:c-constant DISPATCH_METHOD "DISPATCH_METHOD" :unsigned)
(wrap:c-constant DISPATCH_PROPERTYGET "DISPATCH_PROPERTYGET" :unsigned)

*

<C type declarations>+= (U->) [<-D->]
(wrap:declare-c-type word "WORD" :unsigned)

Defines word (links are to index).

<method invokation>= (<-U) [D->]
(wrap:c-function base-invoke "InvokeMethod"
        ((:cptr "IDispatch") dispid lcid word bool :lval :lval)
        :lval)

Defines base-invoke (links are to index).

**** allow dispid to be a symbol/string?? **** allow keys to be symbols/strings??

<method invokation>+= (<-U) [<-D]
(defun idispatch-invoke (ref dispid type &optional
                             args
                             (keydispids
                              (if (member type '(:propput :propputref))
                                 (list DISPID_PROPERTYPUT)
                               nil))
                             (for-value
                              (if (member type '(:propput :propputref))
                                  nil
                                t))
                             (locale (com-locale)))
  (let ((pdisp (idispatch-pointer ref))
        (flags (ecase type
                      (:method (logior DISPATCH_METHOD DISPATCH_PROPERTYGET))
                      (:propget (logior DISPATCH_METHOD DISPATCH_PROPERTYGET))
                      (:propput DISPATCH_PROPERTYPUT)
                      (:propputref DISPATCH_PROPERTYPUTREF))))
    (base-invoke pdisp dispid locale flags for-value args keydispids)))

*

<client support exports>+= (<-U) [<-D->]
idispatch-invoke

*

<invokation support functions>= (U->)
/**** move allocation to Lisp?? avoids danngling pointers on error. */
LVAL InvokeMethod(IDispatch *pdisp, DISPID id, LCID locale, WORD wFlags,
                  BOOL forValue, LVAL args, LVAL nargs)
{
  HRESULT hr;
  UINT argErr;
  EXCEPINFO excepinfo;
  VARIANT result;
  DISPPARAMS dispParams;
  DISPID *nargv;
  int argc, nargc, i;
  VARIANTARG *argv;
  LVAL next;

  /* create the argument structure */
  argc = llength(args);
  if (argc > 0) {
    argv = calloc(argc, sizeof(VARIANTARG));
    if (argv == NULL) xlfail("argument allocation failed");
  }
  else argv = NULL;
  nargc = llength(nargs);
  if (nargc > 0) {
    nargv = calloc(nargc, sizeof(DISPID));
    if (nargv == NULL) xlfail("named argument allocation failed");
  }
  else nargv = NULL;
  for (i = 0, next = args; i < argc; i++, next = cdr(next))
    Lisp2Variant(car(next), VT_VARIANT, &argv[argc - i - 1], TRUE);
  for (i = 0, next = nargs; i < nargc; i++, next = cdr(next))
    nargv[nargc - i - 1] = lisp2ulong(car(next));
  memset(&dispParams, 0, sizeof(DISPPARAMS));
  dispParams.rgvarg = argv;
  dispParams.rgdispidNamedArgs = nargv;
  dispParams.cNamedArgs = nargc;
  dispParams.cArgs = argc;

  /* initialize the result and excetion info */
  if (forValue) VariantInit(&result);
  memset(&excepinfo, 0, sizeof(EXCEPINFO));

  /* invoke the method */
  /**** Perl kludge for WORD? */
  hr = IDispatch_Invoke(pdisp, id, &IID_NULL, locale, wFlags, &dispParams, 
                        forValue ? &result : NULL, &excepinfo, &argErr);

  /* clean up and return */
  for (i = 0; i < argc; i++)
    VariantClear(&argv[i]);
  if (argv != NULL) free(argv);
  if (nargv != NULL) free(nargv);
  if (FAILED(hr)) {
    if (forValue) VariantClear(&result);
    RaiseComError(hr, "Invoke", &excepinfo);
  }
  {
    LVAL val;
    BEGIN_PROTECT {
      val = forValue ? Variant2Lisp(&result) : NIL;
    }
    BEGIN_CLEANUP {
      if (forValue) VariantClear(&result);
    }
    END_PROTECT
    return val;
  }
}

Defines InvokeMethod (links are to index).

<invokation support declarations>= (U->)
LVAL InvokeMethod(IDispatch *pdisp, DISPID id, LCID locale, USHORT wFlags,
                  BOOL forValue, LVAL args, LVAL nargs);

Automation Support

<automation support>= (<-U) [D->]
(defun property (ref &optional meth &rest args)
  (let ((prop-id (if (numberp meth) meth (idispatch-ids-of-names ref meth))))
    (idispatch-invoke ref prop-id :propget args)))

Defines property (links are to index).

<client support exports>+= (<-U) [<-D->]
property

*

<automation support>+= (<-U) [<-D->]
(defun put-property (ref meth &rest args)
  (let ((prop-id (if (numberp meth) meth (idispatch-ids-of-names ref meth))))
    (idispatch-invoke ref prop-id :propput args)))
(defsetf property put-property)

Defines property, put-property (links are to index).

<client support exports>+= (<-U) [<-D->]
put-property

**** Perl uses REF when value is an object--is that a reasonable heuristic? That seems to hold for VBS; the one case of a REF in Excell seems weird.

<automation support>+= (<-U) [<-D->]
(defun put-property-ref (ref meth &rest args)
  (let ((prop-id (if (numberp meth) meth (idispatch-ids-of-names ref meth))))
    (idispatch-invoke ref prop-id :propputref args)))
(defsetf property-ref put-property-ref)

Defines property-ref, put-property-ref (links are to index).

<client support exports>+= (<-U) [<-D->]
put-property-ref

*

<automation support>+= (<-U) [<-D->]
(defun split-invoke-keys (keys)
  (let ((keywords nil)
        (keyargs nil))
    (unless (evenp (length keys)) (error "bad keyword argument list"))
    (loop
     (unless keys (return (values (nreverse keywords) (nreverse keyargs))))
     (let ((k (pop keys))
           (a (pop keys)))
       (unless (keywordp k) (error "~s is not a keyword" k))
       (push k keywords)
       (push a keyargs)))))

Defines split-invoke-keys (links are to index).

<automation support>+= (<-U) [<-D]
(defun invoke-1 (object meth for-value args)
  (let ((keys (member-if #'keywordp args)))
    (if keys
        (let ((baseargs (ldiff args keys)))
          (multiple-value-bind (keywords keyargs) (split-invoke-keys keys)
            (multiple-value-bind (meth-id key-ids)
              (idispatch-ids-of-names object meth keywords)
              (let ((args (append baseargs keyargs)))
                (idispatch-invoke object meth-id :method
                                  args key-ids for-value)))))
      (let ((meth-id (if (numberp meth)
                         meth
                       (idispatch-ids-of-names object meth))))
        (idispatch-invoke object meth-id :method args nil for-value)))))

(defun invoke (object meth &rest args)
  (invoke-1 object meth t args))

(defun invoke-no-value (object meth &rest args)
  (invoke-1 object meth nil args))

Defines invoke, invoke-1, invoke-no-value (links are to index).

<client support exports>+= (<-U) [<-D]
invoke invoke-no-value

*

<test>= [D->]
;;(setf x (get-object "e:\\my documents\\fred.xls"))
;;(setf s (property x :worksheets 1))
(setf x (get-active-object "Excel.application"))
(setf s (property (property x :workbooks 1) :worksheets 1))
(setf r (property s :range "A1" "C2"))
(property r :value)
(property (property s :cells 1 2) :value)
(invoke x :quit)

(setf ie (create-object "InternetExplorer.application"))
(invoke ie :navigate :flags 1 :url "www.stat.umn.edu")

**** mention missing thingy, null thingy here.

Variant Type Conversion

<variant type conversion>= (<-U)
(export '(<variant exports>))
<variant type constants>
<variant structure interface>
<currency conversion>
<structure and object conversion>
<Lisp to variant conversion>
<variant to Lisp conversion>
<variant collections>

Variant Type Constants

<commacro.lsp>=
<package specification>

(defmacro declare-variant-type (name)
  `(progn (export ',name)
          (wrap:c-constant ,name ,(string name) :unsigned)))

Defines declare-variant-type (links are to index).

<variant type constants>= (<-U)
(declare-variant-type VT_ARRAY)
(declare-variant-type VT_BYREF)
(declare-variant-type VT_EMPTY)
(declare-variant-type VT_NULL)
(declare-variant-type VT_UI1)
(declare-variant-type VT_I2)
(declare-variant-type VT_I4)
(declare-variant-type VT_R4)
(declare-variant-type VT_R8)
(declare-variant-type VT_CY)
(declare-variant-type VT_BSTR)
(declare-variant-type VT_ERROR)
(declare-variant-type VT_BOOL)
(declare-variant-type VT_DATE)
(declare-variant-type VT_DISPATCH)
(declare-variant-type VT_VARIANT)
(declare-variant-type VT_UNKNOWN)

Lisp-Level Variant Representation

<variant structure interface>= (<-U) [D->]
(defstruct (variant (:constructor base-make-variant (pointer))
                    (:print-function print-variant))
  pointer)

Defines base-make-variant, variant (links are to index).

<variant exports>= (<-U) [D->]
variant

*

<variant structure interface>+= (<-U) [<-D->]
(defun print-variant (var stream d)
  (let* ((ptr (variant-pointer var))
         (type (when ptr (base-variant-type ptr))))
    (format stream "#<~a~@[, type = ~a~]>"
            (type-of var)
            (when type (variant-type-to-string type)))))

Defines print-variant (links are to index).

<variant structure interface>+= (<-U) [<-D->]
(defun variant-type-to-string (type)
  (let ((byref (/= (logand type VT_BYREF) 0))
        (array (/= (logand type VT_ARRAY) 0))
        (base-type (logand type (lognot (logior VT_BYREF VT_ARRAY)))))
    (format nil "~@[~*VT_BYREF|~]~@[~*VT_ARRAY|~]~a"
            byref
            array
            (case base-type
                  (0 "VT_EMPTY")
                  (1 "VT_NULL")
                  (2 "VT_I2")
                  (3 "VT_I4")
                  (4 "VT_R4")
                  (5 "VT_R8")
                  (6 "VT_CY")
                  (7 "VT_DATE")
                  (8 "VT_BSTR")
                  (9 "VT_DISPATCH")
                  (10 "VT_ERROR")
                  (11 "VT_BOOL")
                  (12 "VT_VARIANT")
                  (13 "VT_UNKNOWN")
                  (17 "VT_UI1")
                  (t base-type)))))

Defines variant-type-to-string (links are to index).

<variant structure interface>+= (<-U) [<-D->]
;;********* fix wrapper
(defun release-variant (var)
  (let ((ptr (variant-pointer var)))
    (when ptr
      (setf (variant-pointer var) nil)
      (debug-print "Unregistering ... ")
      (unregister-com-exit-handler var)
      (debug-print "Releasing VARIANT ... ")
      (variant-clear ptr)
      (debug-print "done~%"))))

(defun wrap-variant (ptr)
  (let ((var (base-make-variant ptr)))
    (register-com-exit-handler var #'release-variant)
    (system:register-finalizer var #'release-variant)
    var))

Defines wrap-variant (links are to index).

<variant structure interface>+= (<-U) [<-D->]
(wrap:c-pointer "VARIANTARG" (:make new-variant) (:offset offset-variant))

Defines new-variant, offset-variant (links are to index).

<variant structure interface>+= (<-U) [<-D->]
(wrap:std-com-function variant-clear "VariantClear" ((:cptr "VARIANTARG")))

Defines variant-clear (links are to index).

Higher Level Interface

<variant structure interface>+= (<-U) [<-D->]
(defun make-variant (arg &optional (type VT_VARIANT))
  (initialize-com)
  (let ((var (new-variant)))
    (lisp-to-variant arg type var nil)
    (wrap-variant var)))

Defines make-variant (links are to index).

<variant exports>+= (<-U) [<-D->]
make-variant

*

<variant structure interface>+= (<-U) [<-D->]
(defun variant-type (var)
  (let ((ptr (variant-pointer var)))
    (when ptr (base-variant-type ptr))))

*

<variant exports>+= (<-U) [<-D->]
variant-type

*

<variant structure interface>+= (<-U) [<-D->]
(wrap:c-function base-variant-type "V_VT" ((:cptr "VARIANTARG")) vartype)

Defines base-variant-type (links are to index).

<C type declarations>+= (U->) [<-D->]
(wrap:declare-c-type vartype "VARTYPE" :unsigned)

Defines vartype (links are to index).

<variant structure interface>+= (<-U) [<-D->]
(defun variant-value (var)
  (variant-to-lisp (variant-pointer var)))

Defines variant-value (links are to index).

<variant exports>+= (<-U) [<-D->]
variant-value

*

<variant structure interface>+= (<-U) [<-D->]
(defun variant-change-type (var type)
  (unless (= (logand type VT_BYREF) 0)
    (error "VT_BYREF flag is not allowed"))
  (let ((new-var (new-variant))
        (ptr (variant-pointer var))
        (lcid (com-locale)))    
    (variant-init new-var)
    (base-variant-change-type-ex new-var ptr lcid 0 type)
    (wrap-variant new-var)))

Defines variant-change-type (links are to index).

<variant exports>+= (<-U) [<-D->]
variant-change-type

*

<variant structure interface>+= (<-U) [<-D->]
(wrap:c-function variant-init "VariantInit" ((:cptr "VARIANTARG")) :void)

Defines variant-init (links are to index).

<variant structure interface>+= (<-U) [<-D->]
(defun variant-value-as (var type)
  (let ((new-var (new-variant))
        (ptr (variant-pointer var))
        (lcid (com-locale)))    
    (variant-init new-var)
    (unwind-protect
        (progn
          (base-variant-change-type-ex new-var ptr lcid 0 type)
          (variant-to-lisp new-var))
      (variant-clear new-var))))

Defines variant-value-as (links are to index).

<variant exports>+= (<-U) [<-D->]
variant-value-as

*

<variant structure interface>+= (<-U) [<-D->]
(wrap:std-com-function base-variant-change-type-ex "VariantChangeTypeEx"
                       ((:cptr "VARIANTARG") (:cptr "VARIANTARG")
                        lcid :unsigned vartype))

Defines base-variant-change-type-ex (links are to index).

<dispatch constants>+= (U->) [<-D->]
(wrap:c-constant DISP_E_PARAMNOTFOUND "DISP_E_PARAMNOTFOUND" :unsigned)

Defines DISP_E_PARAMNOTFOUND (links are to index).

<variant structure interface>+= (<-U) [<-D]
(defun make-missing-variant () (make-variant DISP_E_PARAMNOTFOUND VT_ERROR))
(defun make-empty-variant () (make-variant nil VT_EMPTY))
(defun make-null-variant () (make-variant nil VT_NULL))

Defines make-empty-variant, make-missing-variant, make-null-variant (links are to index).

<variant exports>+= (<-U) [<-D->]
make-missing-variant
make-empty-variant
make-null-variant

Currency Conversion

<variant type conversion declarations>= (U->) [D->]
LVAL CY2Lisp(ULONG hi, ULONG lo);
void Lisp2CY(LVAL val, CY *pcy);

Defines CY2Lisp, Lisp2CY (links are to index).

<currency conversion>= (<-U) [D->]
(wrap:c-callback "CY2Lisp" currency-to-lisp (:unsigned :unsigned) :lval
                 :static nil)
(wrap:c-callback "Lisp2CY" lisp-to-currency (:lval (:cptr "CY")) :void
                 :static nil)

Defines CY2Lisp, Lisp2CY (links are to index).

<currency conversion>+= (<-U) [<-D->]
(defconstant currency-cut (expt 2 32))
(defconstant min-currency (- (expt 2 63)))
(defconstant max-currency (- (expt 2 63) 1))

Defines currency-cut, max-currency, min-currency (links are to index).

<currency conversion>+= (<-U) [<-D->]
(defun currency-to-lisp (hi lo)
  (let* ((neg (not (zerop (logand (expt 2 31) hi))))
         (ahi (if neg (- currency-cut hi 1) hi))
         (alo (if neg (- currency-cut lo) lo))
         (aval (xlisp:divide (+ (* currency-cut ahi) alo) 10000)))
    (if neg (- aval) aval)))

Defines currency-to-lisp (links are to index).

<currency conversion>+= (<-U) [<-D->]
(defun lisp-to-currency (val pcy)
  (let ((ival (round (* val 10000))))
    (unless (<= min-currency ival max-currency)
      (error "the value ~a is out of the currency range" ival))
    (multiple-value-bind (ahi alo) (floor (abs ival) currency-cut)
      (let ((hi (if (minusp ival) (- currency-cut ahi 1) ahi))
            (lo (if (minusp ival) (- currency-cut alo) alo)))
        (set-currency pcy hi lo)))))

Defines lisp-to-currency (links are to index).

<currency conversion>+= (<-U) [<-D]
(wrap:c-lines "
static void SetCY(CY *pcy, ULONG hi, ULONG lo)
{
  pcy->s.Hi = (long) hi;
  pcy->s.Lo = lo;
}")
(wrap:c-function set-currency "SetCY" ((:cptr "CY") :unsigned :unsigned) :void)

Defines SetCY (links are to index).

String Conversion

<variant type conversion functions>= (U->) [D->]
static BSTR LispString2BSTR(LVAL val)
{
  char *s;
  int n;
  BSTR bs;

  if (! stringp(val)) xlbadtype(val);
  s = getstring(val);
  n = MultiByteToWideChar(CP_ACP, 0, s, -1, NULL, 0);
  if (n == 0) xlfail("conversion to BSTR failed");
  bs = SysAllocStringLen(NULL, n);
  if (bs == NULL) xlfail("BSTR allocation failed");
  MultiByteToWideChar(CP_ACP, 0, s, -1, bs, n);
  return bs;
}

Defines LispString2BSTR (links are to index).

<variant type conversion functions>+= (U->) [<-D->]
LVAL BSTR2LispString(BSTR *bs)
{
  LVAL val;
  int n = WideCharToMultiByte(CP_ACP, 0, bs, -1, NULL, 0, NULL, NULL);
  if (n == 0) xlfail("BSTR conversion failed");
  val = newstring(n - 1);
  WideCharToMultiByte(CP_ACP, 0, bs, -1, getstring(val), n, NULL, NULL);
  return val;
}

Defines BSTR2LispString (links are to index).

<type conversion declarations>+= (U->) [<-D]
LVAL BSTR2LispString(BSTR *bs);

Defines BSTR2LispString (links are to index).

Structure to Variant Conversion

<structure and object conversion>= (<-U) [D->]
(wrap:c-callback "LispStruct2Variant" struct-to-variant
                 (:lval vartype (:cptr "VARIANTARG") bool) :void
                 :static nil)

Defines LispStruct2Variant (links are to index).

<variant type conversion declarations>+= (U->) [<-D->]
void LispStruct2Variant(LVAL val, VARTYPE type, VARIANTARG *pvar, BOOL ref_ok);

Defines LispStruct2Variant (links are to index).

The callback handles variant structures and automation/com object and server structures. For variants, a copt is made if the variant argument is already the right type; otherwise VariantChangeTypeEx is used. Just to be safe, I'm using the VariantCopyInd function to force resolving of indirections--I don't think it is possible for there to be any, given where the variant structures come form, but I'm not sure.

<structure and object conversion>+= (<-U) [<-D->]
(defun struct-to-variant (val type pvar ref-ok)
  (etypecase val
    (variant 
     (let ((ptr (variant-pointer val)))
       (if (or (= type VT_VARIANT) (= type (variant-type val)))
           (base-variant-copy-ind pvar ptr)
         (base-variant-change-type-ex pvar ptr (com-locale) 0 type))))
    (variant-ref
     (unless ref-ok (error "variant reference not allowed"))
     (let ((ref-val (variant-ref-variant val)))
       (unless (or (= type VT_VARIANT) (= type (variant-type ref-val)))
         (error "can't convert variant type in a reference"))
       (variant-ref-copy (variant-pointer ref-val) pvar)))
    (idispatch
     (com-pointer-to-variant val (idispatch-pointer val) type pvar t))
    (iunknown
     (com-pointer-to-variant val (iunknown-pointer val) type pvar nil))
    (auto-server
     (com-pointer-to-variant val (auto-server-pointer val) type pvar t))
    (generic-server
     (com-pointer-to-variant val (generic-server-pointer val) type pvar nil))))

Defines struct-to-variant (links are to index).

**** document this stuff

<structure and object conversion>+= (<-U) [<-D->]
(wrap:c-lines "
static void VariantRefCopy(VARIANTARG *prefvar, VARIANTARG *pvar)
{
  VariantClear(pvar);
  V_VT(pvar) = V_VT(prefvar) | VT_BYREF;
  V_I4REF(pvar) = &(V_I4(prefvar));
}")
(wrap:c-function variant-ref-copy "VariantRefCopy"
                 ((:cptr "VARIANTARG") (:cptr "VARIANTARG")) :void)

Defines variant-ref-copy, VariantRefCopy (links are to index).

Interface pointers are all handled by essentially the same code, so it is broken out into a separate function. The value itself is passed to allow an error message to be constructed if necessary. The cast to an IDispatch poinbter is only needed for automation server objects. **** Maybe those should just be represented as IDispatch pointers as well.

<structure and object conversion>+= (<-U) [<-D->]
(defun com-pointer-to-variant (val ptr type pvar dispatch)
  (cond
   ((and dispatch (or (= type VT_VARIANT) (= type VT_DISPATCH)))
    (lisp-to-variant-ex (cast-idispatch ptr) VT_DISPATCH pvar))
   ((= type VT_UNKNOWN)
    (lisp-to-variant-ex (cast-iunknown ptr) VT_UNKNOWN pvar))
   (t (error "can't convert ~a to ~a VARIANT"
             (type-of val)
             (variant-type-to-string type)))))

Defines com-pointer-to-variant (links are to index).

<structure and object conversion>+= (<-U) [<-D->]
(wrap:c-pointer "IUnknown" (:cast cast-iunknown))

Defines cast-iunknown (links are to index).

The IDispatch casting function is defined by

<structure and object conversion>+= (<-U) [<-D->]
(wrap:c-pointer "IDispatch" (:cast cast-idispatch))

Defines cast-idispatch (links are to index).

Even though I only use VariantCopyInd, I've also defined an interface for VariantCopy just in case i change my mind.

<structure and object conversion>+= (<-U) [<-D->]
(wrap:std-com-function base-variant-copy "VariantCopy"
                       ((:cptr "VARIANTARG") (:cptr "VARIANTARG")))
(wrap:std-com-function base-variant-copy-ind "VariantCopyInd"
                       ((:cptr "VARIANTARG") (:cptr "VARIANTARG")))

Defines base-variant-copy, base-variant-copy-ind (links are to index).

Object to Variant Conversion

<structure and object conversion>+= (<-U) [<-D->]
(wrap:c-callback "LispObject2Variant" object-to-variant
                 (:lval vartype (:cptr "VARIANTARG")) :void
                 :static nil)

Defines LispObject2Variant (links are to index).

<variant type conversion declarations>+= (U->) [<-D->]
void LispObject2Variant(LVAL val, VARTYPE type, VARIANTARG *pvar);

Defines LispObject2Variant (links are to index).

For the moment, the callback just signals an error. To allow Lisp objects to be put on the COM bus, just provide an appropriate definition for the object-to-variant function.

<structure and object conversion>+= (<-U) [<-D]
(defun object-to-variant (object type pvar)
  (error "can't convert Lisp objects to VARIANTs"))

Defines object-to-variant (links are to index).

Safe Array to Lisp Array Conversion

<variant type conversion functions>+= (U->) [<-D->]
static long calculate_index(long k, int rank, long *dims, long *idx)
{
  long nk, face;
  int i;

  for (i = 0, face = 1; i < rank; i++)
    face *= dims[i];

  for (i = 0; i < rank; i++) {
    face /= dims[i];
    idx[i] = k / face;
    k = k % face;
  }

  for (i = 0, nk = 0; i < rank; i++)
    nk = dims[rank - i - 1] * nk + idx[rank - i - 1];

  return nk;
}

Defines calculate_index (links are to index).

**** incrase to 32 or 64? check limis in xlisp

<variant type conversion functions>+= (U->) [<-D->]
#define MAX_RANK 10
#define AS_PTR(t,p) ((t *) (p))

static LVAL SafeArray2Lisp(SAFEARRAY *psa, VARTYPE vt) {
  LVAL val, dims, elem;
  long lower, upper, size, i, n;
  int rank = SafeArrayGetDim(psa);
  long idims[MAX_RANK];
  long idx[MAX_RANK];
  void *sadata;
  HRESULT hr;

  if (rank > MAX_RANK) xlfail("array rank is too large to convert");

  xlstkcheck(2);
  xlsave(val);
  xlsave(dims);
  dims = rank == 1 ? NIL : newvector(rank);
  for (size = 1, i = 1; i <= rank; i++) {
    SafeArrayGetLBound(psa, i, &lower);
    SafeArrayGetUBound(psa, i, &upper);
    n = upper - lower + 1;
    idims[i - 1] = n;
    size *= n;
    if (rank != 1) setelement(dims, i - 1, cvfixnum((FIXTYPE) n));
  }

  val = newvector(size);
  hr = SafeArrayAccessData(psa, &sadata);
  if (SUCCEEDED(hr)) {
    BEGIN_PROTECT {
      for (i = 0; i < size; i++) {
        long j = calculate_index(i, rank, idims, idx);
        switch (vt) {
        case VT_UI1: elem = cvfixnum(AS_PTR(unsigned char, sadata)[j]); break;
        case VT_I2: elem = cvfixnum(AS_PTR(short, sadata)[j]); break;
        case VT_I4: elem = cvfixnum(AS_PTR(long, sadata)[j]); break;
        case VT_R4: elem = cvflonum(AS_PTR(float, sadata)[j]); break;
        case VT_R8: elem = cvflonum(AS_PTR(double, sadata)[j]); break;
        case VT_CY:
          {
            CY cy = AS_PTR(CY, sadata)[j];
            elem = CY2Lisp(cy.s.Hi, cy.s.Lo);
          }
          break;
        case VT_DATE: elem = cvflonum(AS_PTR(DATE, sadata)[j]); break;
        case VT_BSTR: elem = BSTR2LispString(AS_PTR(BSTR, sadata)[j]); break;
        case VT_DISPATCH:
          {
            IDispatch *pdisp = AS_PTR(IDispatch *, sadata)[j];
            if (pdisp != NULL) IDispatch_AddRef(pdisp);
            elem = IDispatch2Lisp(pdisp);
          }
          break;
        case VT_ERROR: elem = ulong2lisp(AS_PTR(SCODE, sadata)[j]); break;
        case VT_BOOL:
          elem = AS_PTR(VARIANT_BOOL, sadata)[j]?s_true : NIL;
          break;
        case VT_VARIANT:
          elem = Variant2Lisp(&AS_PTR(VARIANT, sadata)[j]);
          break;
        case VT_UNKNOWN:
          {
            IUnknown *pdisp = AS_PTR(IUnknown *, sadata)[j];
            if (pdisp != NULL) IUnknown_AddRef(pdisp);
            elem = IUnknown2Lisp(pdisp);
          }
          break;
        default: xlfail("can't convert array");
        }
        setelement(val, i, elem);
      }
    }
    BEGIN_CLEANUP {
      SafeArrayUnaccessData(psa);
    }
    END_PROTECT
  }
  else xlfail("failed to access array data");

  if (rank != 1) val = newdarray(dims, val);
  xlpopn(2);
  return val;
}

Defines SafeArray2Lisp (links are to index).

Lisp Array to Safe Array Conversion

<variant type conversion functions>+= (U->) [<-D->]
DECLARE_CPTR_TYPE(void)
DECLARE_CPTR_TYPE(IDispatch)
DECLARE_CPTR_TYPE(IUnknown)

static IDispatch *Lisp2IDispatch(LVAL val)
{
  if (! cptr_type_p(val, CPTR_TYPE(IDispatch)) || getcpaddr(val) == NULL)
    xlbadtype(val);
  return getcpaddr(val);
}

static IUnknown *Lisp2IUnknown(LVAL val)
{
  if (! cptr_type_p(val, CPTR_TYPE(IUnknown)) || getcpaddr(val) == NULL)
    xlbadtype(val);
  return getcpaddr(val);
}

Defines Lisp2IDispatch, Lisp2IUnknown (links are to index).

<variant type conversion functions>+= (U->) [<-D->]
static SAFEARRAY *LispArray2SafeArray(LVAL val, VARTYPE vt) {
  LVAL data, elem;
  long size, i, n, rank, idims[MAX_RANK], idx[MAX_RANK];
  SAFEARRAY *psa;
  SAFEARRAYBOUND sabounds[MAX_RANK];
  void *sadata;
  HRESULT hr;

  switch (ntype(val)) {
  case STRING:
  case VECTOR:
  case TVEC:
    data = val;
    rank = 1;
    size = gettvecsize(data);
    sabounds[0].lLbound = 0;
    sabounds[0].cElements = size;
    break;
  case DARRAY:
    {
      LVAL dims = getdarraydim(val);
      data = getdarraydata(val);
      rank = getdarrayrank(val);
      for (size = 1, i = 0; i < rank; i++) {
        n = getfixnum(getelement(dims, i));
        idims[i] = n;
        size *= n;
        sabounds[i].lLbound = 0;
        sabounds[i].cElements = n;
      }
    }
    break;
  default: xlbadtype(val);
  }

  if (rank > MAX_RANK) xlfail("array rank is too large to convert");
  if (rank == 0) xlfail("can't convert zero-rank arrays");

  psa = SafeArrayCreate(vt, rank, sabounds);
  if (psa == NULL) xlfail("SafeArray creation failed");

  hr = SafeArrayAccessData(psa, &sadata);
  if (SUCCEEDED(hr)) {
    BEGIN_PROTECT {
      xlsave1(elem);
      for (i = 0; i < size; i++) {
        long j = calculate_index(i, rank, idims, idx);
        elem = gettvecelement(data, i);
        switch (vt) {
        case VT_UI1:
          AS_PTR(unsigned char, sadata)[j] = lisp2ulong(elem);
          break;
        case VT_I2: AS_PTR(short, sadata)[j] = lisp2long(elem); break;
        case VT_I4: AS_PTR(long, sadata)[j] = lisp2long(elem); break;
        case VT_R4: AS_PTR(float, sadata)[j] = makefloat(elem); break;
        case VT_R8: AS_PTR(double, sadata)[j] = makefloat(elem); break;
        case VT_CY: Lisp2CY(elem, &AS_PTR(double, sadata)[j]); break;
        case VT_DATE: AS_PTR(DATE, sadata)[j] = makefloat(elem); break;
        case VT_BSTR: AS_PTR(BSTR, sadata)[j] = LispString2BSTR(elem); break;
        case VT_DISPATCH:
          {
            IDispatch *pdisp = Lisp2IDispatch(elem);
            if (pdisp != NULL) IDispatch_AddRef(pdisp);
            AS_PTR(IDispatch *, sadata)[j] = pdisp;
          }
          break;
        case VT_ERROR: AS_PTR(SCODE, sadata)[j] = lisp2ulong(elem); break;
        case VT_BOOL:
          AS_PTR(VARIANT_BOOL, sadata)[j] = null(elem)?0 : -1;
          break;
        case VT_VARIANT:
          Lisp2Variant(elem, VT_VARIANT, &AS_PTR(VARIANT, sadata)[j], FALSE);
          break;
        case VT_UNKNOWN:
          {
            IUnknown *punk = Lisp2IUnknown(elem);
            if (punk != NULL) IUnknown_AddRef(punk);
            AS_PTR(IUnknown *, sadata)[j] = punk;
          }
          break;
        default: xlfail("can only create VARIANT arrays for now");
        }
      }
      xlpop();
    }
    BEGIN_CLEANUP {
      SafeArrayUnaccessData(psa);
      if (UNWINDING) SafeArrayDestroy(psa);
    }
    END_PROTECT
  }
  else {
    SafeArrayDestroy(psa);
    xlfail("failed to access array data");
  }
  return psa;
}

Defines LispArray2SafeArray (links are to index).

Lisp to Variant Conversion

<variant type conversion functions>+= (U->) [<-D->]
void Lisp2Variant(LVAL val, VARTYPE type, VARIANTARG *pvar, BOOL ref_ok)
{
  if (structp(val))
    LispStruct2Variant(val, type, pvar, ref_ok);
  else if (objectp(val))
    LispObject2Variant(val, type, pvar);
  else if (type == VT_VARIANT) {
    switch (ntype(val)) {
    case SYMBOL:
      if (val == s_true || val == NIL) Lisp2VariantEx(val, VT_BOOL, pvar);
      else xlbadtype(val);
      break;
    case FIXNUM: Lisp2VariantEx(val, VT_I4, pvar); break;
    case BIGNUM:
    case FLONUM: Lisp2VariantEx(val, VT_R8, pvar); break;
    case STRING: Lisp2VariantEx(val, VT_BSTR, pvar); break;
    case VECTOR:
    case TVEC:
    case DARRAY: Lisp2VariantEx(val, VT_ARRAY | VT_VARIANT, pvar); break;
    default: xlbadtype(val);
    }
  }
  else Lisp2VariantEx(val, type, pvar);
}

Defines Lisp2Variant (links are to index).

<variant type conversion declarations>+= (U->) [<-D->]
void Lisp2Variant(LVAL val, VARTYPE type, VARIANTARG *pvar, BOOL ref_ok);

Defines Lisp2Variant (links are to index).

<Lisp to variant conversion>= (<-U) [D->]
(wrap:c-function lisp-to-variant "Lisp2Variant"
                 (:lval vartype (:cptr "VARIANTARG") bool)
                 :void)

Defines lisp-to-variant (links are to index).

<variant type conversion functions>+= (U->) [<-D->]
void Lisp2VariantEx(LVAL val, VARTYPE type, VARIANTARG *pvar)
{
  VariantInit(pvar);
  switch (type) {
  case VT_EMPTY: break;
  case VT_NULL: break;
  case VT_UI1: V_UI1(pvar) = lisp2ulong(val); break;
  case VT_I2: V_I2(pvar) = lisp2long(val); break;
  case VT_I4: V_I4(pvar) = lisp2long(val); break;
  case VT_R4: V_R4(pvar) = makefloat(val); break;
  case VT_R8: V_R8(pvar) = makefloat(val); break;
  case VT_CY: Lisp2CY(val, &V_CY(pvar)); break;
  case VT_DATE: V_DATE(pvar) = makefloat(val); break;
  case VT_BSTR: V_BSTR(pvar) = LispString2BSTR(val); break;
  case VT_DISPATCH:
    V_DISPATCH(pvar) = Lisp2IDispatch(val);    
    if (V_DISPATCH(pvar) != NULL) IDispatch_AddRef(V_DISPATCH(pvar));
    break;
  case VT_ERROR: V_ERROR(pvar) = lisp2ulong(val); break;
  case VT_BOOL: V_BOOL(pvar) = null(val) ? 0 : -1; break;
  case VT_UNKNOWN:
    V_UNKNOWN(pvar) = Lisp2IUnknown(val);    
    if (V_UNKNOWN(pvar) != NULL) IUnknown_AddRef(V_UNKNOWN(pvar));
    break;
  default:
    if (VT_ARRAY & type)
      V_ARRAY(pvar) = LispArray2SafeArray(val, type & ~VT_ARRAY);
    else xlfail("conversion not supported");
  }
  V_VT(pvar) = type;
}

Defines Lisp2VariantEx (links are to index).

<variant type conversion declarations>+= (U->) [<-D->]
void Lisp2VariantEx(LVAL val, VARTYPE type, VARIANTARG *pvar);

Defines Lisp2VariantEx (links are to index).

<Lisp to variant conversion>+= (<-U) [<-D->]
(wrap:c-function lisp-to-variant-ex "Lisp2VariantEx"
                 (:lval vartype (:cptr "VARIANTARG"))
                 :void)

Defines lisp-to-variant-ex (links are to index).

Variant References

<Lisp to variant conversion>+= (<-U) [<-D->]
(defstruct (variant-ref (:constructor base-make-variant-ref (variant))
                        (:print-function print-variant-ref))
  variant)

Defines base-make-variant-ref, variant-ref (links are to index).

<variant exports>+= (<-U) [<-D->]
variant-ref

*

<Lisp to variant conversion>+= (<-U) [<-D->]
(defun print-variant-ref (ref stream d)
  (let* ((var (variant-ref-variant ref))
         (ptr (when var (variant-pointer var)))
         (type (when ptr (base-variant-type ptr))))
    (format stream "#<~a~@[, type = ~a~]>"
            (type-of ref)
            (when type (variant-type-to-string type)))))

Defines print-variant-ref (links are to index).

<Lisp to variant conversion>+= (<-U) [<-D->]
(defun make-variant-ref (value type)
  (initialize-com)
  (let ((var (cond
              ((null value)
               (let ((ptr (new-variant)))
                 (set-variant-type ptr type)
                 (wrap-variant ptr)))
              ((variant-p value) value)
              (t (make-variant value type)))))
    (base-make-variant-ref var)))

Defines make-variant-ref (links are to index).

<variant exports>+= (<-U) [<-D->]
make-variant-ref

*

<Lisp to variant conversion>+= (<-U) [<-D->]
(defun variant-ref-value (ref)
  (variant-value (variant-ref-variant ref)))

Defines variant-ref-value (links are to index).

<variant exports>+= (<-U) [<-D->]
variant-ref-value

*

<Lisp to variant conversion>+= (<-U) [<-D]
(wrap:c-lines "
static void SetVariantType(VARIANTARG *pvar, VARTYPE type)
{
  V_VT(pvar) = type;
}")
(wrap:c-function set-variant-type "SetVariantType"
                 ((:cptr "VARIANTARG") vartype) :void)

Defines set-variant-type, SetVariantType (links are to index).

***** need to check that reference counts work right

Variant to Lisp Conversion

<variant to Lisp conversion>= (<-U) [D->]
(defvar *null-variant-value* :null)
(defvar *empty-variant-value* :empty)

Defines *empty-variant-value*, *null-variant-value* (links are to index).

<variant exports>+= (<-U) [<-D->]
*null-variant-value*
*empty-variant-value*

*

<variant to Lisp conversion>+= (<-U) [<-D->]
(wrap:c-read-variable "GetNullVARIANT" *null-variant-value* :lval :static nil)
(wrap:c-read-variable "GetEmptyVARIANT" *empty-variant-value* :lval :static nil)

Defines GetEmptyVARIANT, GetNullVARIANT (links are to index).

<variant type conversion declarations>+= (U->) [<-D->]
LVAL GetNullVARIANT(void);
LVAL GetEmptyVARIANT(void);

Defines GetEmptyVARIANT, GetNullVARIANT (links are to index).

<variant type conversion functions>+= (U->) [<-D]
#define VAR_VAL(t,x) (V_ISBYREF(x) ? *V_##t##REF(x) : V_##t(x))
LVAL Variant2Lisp(VARIANT *pvar)
{
  LVAL val;
  if (V_ISARRAY(pvar)) {
    VARTYPE vt = V_VT(pvar) & ~ (VT_ARRAY|VT_BYREF);
    val = SafeArray2Lisp(VAR_VAL(ARRAY, pvar), vt);
  }
  else {
    switch (V_VT(pvar) & ~VT_BYREF) {
    case VT_EMPTY: val = GetEmptyVARIANT(); break;
    case VT_NULL: val = GetNullVARIANT(); break;
    case VT_UI1: val = cvfixnum(VAR_VAL(UI1, pvar)); break;
    case VT_I2: val = cvfixnum(VAR_VAL(I2, pvar)); break;
    case VT_I4: val = cvfixnum(VAR_VAL(I4, pvar)); break;
    case VT_R4: val = cvflonum(VAR_VAL(R4, pvar)); break;
    case VT_R8: val = cvflonum(VAR_VAL(R8, pvar)); break;
    case VT_CY: val = CY2Lisp(V_CY(pvar).s.Hi, V_CY(pvar).s.Lo); break;
    case VT_DATE: val = cvflonum(VAR_VAL(DATE, pvar)); break;
    case VT_BSTR: val = BSTR2LispString(V_BSTR(pvar)); break;
    case VT_DISPATCH:
      {
        IDispatch *pdisp = VAR_VAL(DISPATCH, pvar);
        if (pdisp != NULL) IDispatch_AddRef(pdisp);
        val = IDispatch2Lisp(pdisp);
      }
      break;
    case VT_ERROR: val = ulong2lisp(VAR_VAL(ERROR, pvar)); break;
    case VT_BOOL: val = VAR_VAL(BOOL, pvar) ? s_true : NIL; break;
    case VT_UNKNOWN:
      {
        IUnknown *pdisp = VAR_VAL(UNKNOWN, pvar);
        if (pdisp != NULL) IUnknown_AddRef(pdisp);
        val = IUnknown2Lisp(pdisp);
      }
      break;
    default: xlfail("unsupported variant type");
    }
  }
  return val;
}

<variant type conversion declarations>+= (U->) [<-D]
LVAL Variant2Lisp(VARIANT *pvar);

*

<variant to Lisp conversion>+= (<-U) [<-D]
(wrap:c-function variant-to-lisp "Variant2Lisp" ((:cptr "VARIANTARG")) :lval)

Variant Collections

<dispatch constants>+= (U->) [<-D]
(wrap:c-constant DISPID_NEWENUM "DISPID_NEWENUM" :integer)

Defines DISPID_NEWENUM (links are to index).

<variant collections>= (<-U) [D->]
(wrap:c-lines "
#define GetEnumVARIANT(a,b) IUnknown_QueryInterface(a,&IID_IEnumVARIANT,b)")
(wrap:std-com-function base-get-enum-variant "GetEnumVARIANT"
                       ((:cptr "IUnknown") (:value (:cptr "IEnumVARIANT"))))
(wrap:c-function release-enum-variant "IEnumVARIANT_Release"
                 ((:cptr "IEnumVARIANT")) :void)

Defines base-get-enum-variant, GetEnumVARIANT (links are to index).

**** just use query-interface here??

<variant collections>+= (<-U) [<-D->]
(defun get-enum-variant (object)
  (let ((enum (invoke object DISPID_NEWENUM)))
    (base-get-enum-variant (iunknown-pointer enum))))

Defines get-enum-variant (links are to index).

<variant collections>+= (<-U) [<-D->]
(wrap:c-lines "
#define GetNextVARIANT(a,b) IEnumVARIANT_Next(a,1,b,NULL)")
(wrap:c-function enum-variant-next "GetNextVARIANT"
                 ((:cptr "IEnumVARIANT") (:cptr "VARIANTARG")) hresult)

Defines enum-variant-next, GetNextVARIANT (links are to index).

**** lift unwind-protect out of loop?

<variant collections>+= (<-U) [<-D]
(defmacro do-collection ((var object &optional value) &body body)
  (let ((colsym (gensym))
        (varsym (gensym)))
    `(let ((,colsym (get-enum-variant ,object)))
       (unwind-protect
           (let ((,varsym (new-variant)))
             (variant-init ,varsym)
             (loop
              (unwind-protect
                  (progn
                    (when (/= (enum-variant-next ,colsym ,varsym) S_OK)
                      (let ((,var nil)) (return ,value)))
                    (let ((,var (variant-to-lisp ,varsym))) ,@body))
                (variant-clear ,varsym))))
         (release-enum-variant ,colsym)))))

Defines do-collection (links are to index).

<variant exports>+= (<-U) [<-D]
do-collection

*

<test>+= [<-D->]
(let* ((file "\\users\\luke\\working\\win32\\win32com\\cars.xls")
       (workbook (get-object file))
       (sheets (property workbook :worksheets))
       (val nil))
  (do-collection (s sheets (nreverse val))
    (push (property s :name) val)))

Type Libraries and Type Information

<type libraries and type information>= (U->)
<type libraries>
<type information>
<finding coclasses>

Type Libraries

<type libraries>= (<-U)
(export '(<type library exports>))
<loading type libraries>
<searching type libraries by name>
<type library documentation>
<type library attributes>
<type library entries>
<higher level type library functions>

Loading Type Libraries

<loading type libraries>= (<-U)
(wrap:std-com-function base-load-type-lib "LoadTypeLib"
                       ((:cptr "WCHAR") (:value (:cptr "ITypeLib"))))

(defun load-type-lib (path)
  (initialize-com)
  (system:without-interrupts
   (wrap-itypelib (base-load-type-lib (string-to-wide-string path)))))

Defines base-load-type-lib, load-type-lib (links are to index).

<type library exports>= (<-U) [D->]
load-type-lib

Searching by Name

<searching type libraries by name>= (<-U) [D->]
;;**** use pointer wrappers
;;**** allow for unsigned's in wrappers?
(wrap:c-pointer (:unsigned "int")
                (:make make-c-uint)
                (:get get-c-uint nil :integer)
                (:set set-c-uint nil :integer))

(wrap:c-pointer (:cptr "ITypeInfo")
                (:make make-type-info-array)
                (:get get-type-info-element nil (:cptr "ITypeInfo")))

(wrap:std-com-function base-itypelib-find-name "ITypeLib_FindName"
                       ((:cptr "ITypeLib") (:cptr "WCHAR") :integer
                        (:cptr (:cptr "ITypeInfo")) (:cptr "DISPID")
                        (:cptr (:unsigned "int"))))

*

<searching type libraries by name>+= (<-U) [<-D]
(defun itypelib-find-name (lib name &optional (count 1 count-supplied-p))
  (let ((plib (itypelib-pointer lib))
        (wname (string-to-wide-string (string name)))
        (ptis (make-type-info-array count))
        (pids (make-dispid count))
        (pcount (make-c-uint 1)))
    (set-c-uint pcount count)
    (base-itypelib-find-name plib wname 0 ptis pids pcount)
    (let ((nfound (get-c-uint pcount)))
      (cond
       ((= nfound 0) (values nil nil))
       (count-supplied-p
        (let ((infos nil)
              (memids nil))
          (dotimes (i nfound (values (nreverse infos) (nreverse memids)))
            (push (wrap-itypeinfo (get-type-info-element ptis i)) infos)
            (push (get-dispid pids i) memids))))
       (t (values (wrap-itypeinfo (get-type-info-element ptis))
                  (get-dispid pids)))))))

Defines itypelib-find-name (links are to index).

<type library exports>+= (<-U) [<-D->]
itypelib-find-name

Documentation

<type library documentation>= (<-U) [D->]
(wrap:std-com-function base-itypelib-documentation "ITypeLib_GetDocumentation"
                       ((:cptr "ITypeLib") :integer
                        (:cptr "BSTR" t) (:cptr "BSTR" t)
                        (:cptr "long" t) (:cptr "BSTR" t)))

(defun type-lib-documentation (lib &optional index all)
  (let ((i (if index index -1))
        (ptr (itypelib-pointer lib)))
    (get-documentation #'base-itypelib-documentation ptr i all)))

(defun itypelib-name (lib)
  (let ((ptr (itypelib-pointer lib)))
    (get-documentation #'base-itypelib-documentation ptr -1 nil)))

Defines base-itypelib-documentation, itypelib-name, type-lib-documentation (links are to index).

<type library exports>+= (<-U) [<-D->]
type-lib-documentation itypelib-name

*

<type library documentation>+= (<-U) [<-D->]
(wrap:c-pointer "BSTR"
                (:make make-bstr-array)
                (:get get-bstr nil (:cptr "WCHAR")))

(wrap:c-pointer "long" (:make make-long-array) (:get get-long nil :integer))

(wrap:c-function free-bstr "SysFreeString" ((:cptr "WCHAR")) :void)

(wrap:c-constant MEMBERID_NIL "MEMBERID_NIL" :integer)

Defines free-bstr, get-bstr, make-bstr-array, MEMBERID_NIL (links are to index).

<type library documentation>+= (<-U) [<-D]
;;;**** assume that on failure BSTR's are null
(defun get-documentation (fun ptr index all)
  (system:without-interrupts
   (let* ((bsa-name (make-bstr-array))
          (bsa-doc (when all (make-bstr-array)))
          (la-help (when all (make-long-array)))
          (bsa-help (when all (make-bstr-array))))
     (funcall fun ptr index bsa-name bsa-doc la-help bsa-help)
     (let ((bs-name (get-bstr bsa-name))
           (bs-doc (when all (get-bstr bsa-doc)))
           (bs-help (when all (get-bstr bsa-help))))
       (unwind-protect
           (let ((name (if bs-name (wide-string-to-string bs-name) nil)))
             (if all
                 (values name
                         (when bs-doc (wide-string-to-string bs-doc))
                         (get-long la-help)
                         (when bs-help (wide-string-to-string bs-help)))
               name))
         (when bs-name (free-bstr bs-name))
         (when bs-doc (free-bstr bs-doc))
         (when bs-help (free-bstr bs-help)))))))

Defines get-documentation (links are to index).

Attributes

<type library attributes>= (<-U) [D->]
(wrap:std-com-function get-tlibattr "ITypeLib_GetLibAttr"
                       ((:cptr "ITypeLib") (:value (:cptr "TLIBATTR"))))

(wrap:c-function release-tlibattr "ITypeLib_ReleaseTLibAttr"
                 ((:cptr "ITypeLib") (:cptr "TLIBATTR")) :void)

Defines get-tlibattr, release-tlibattr (links are to index).

<type library attributes>+= (<-U) [<-D->]
(wrap:c-pointer "TLIBATTR"
                (:get tlibattr-lcid "lcid" :integer)
                (:get tlibattr-syskind "syskind" :integer)
                (:get tlibattr-major "wMajorVerNum" :integer)
                (:get tlibattr-minor "wMinorVerNum" :integer)
                (:get tlibattr-flags "wLibFlags" :integer))

(wrap:c-lines "
static void GetTLibAttrGUID(TLIBATTR *pta, GUID *pid)
{
  *pid = pta->guid;
}")
(wrap:c-function tlibattr-get-guid "GetTLibAttrGUID"
                 ((:cptr "TLIBATTR") (:cptr "GUID")) :void)

Defines tlibattr-flags, tlibattr-get-guid, tlibattr-lcid, tlibattr-major, tlibattr-minor, tlibattr-syskind (links are to index).

<type library attributes>+= (<-U) [<-D->]
(defmacro with-tlibattr ((asym lib) &body body)
  (let ((psym (gensym)))
    `(system:without-interrupts
      (let* ((,psym (itypelib-pointer ,lib))
             (,asym (get-tlibattr ,psym)))
        (unwind-protect
            (progn ,@body)
          (release-tlibattr ,psym ,asym))))))

Defines with-tlibattr (links are to index).

<type library attributes>+= (<-U) [<-D->]
(defun itypelib-guid (lib)
  (with-tlibattr (attr lib)
    (let ((guid (make-guid-data)))
      (tlibattr-get-guid attr guid)
      (make-guid guid))))

Defines itypelib-guid (links are to index).

<type library exports>+= (<-U) [<-D->]
itypelib-guid

*

<type library attributes>+= (<-U) [<-D->]
(defun itypelib-lcid (lib)
  (with-tlibattr (attr lib) (tlibattr-lcid attr)))

Defines itypelib-lcid (links are to index).

<type library exports>+= (<-U) [<-D->]
itypelib-lcid

*

<type library attributes>+= (<-U) [<-D->]
(defun itypelib-syskind (lib)
  (with-tlibattr (attr lib)
    (let ((syskind (tlibattr-syskind attr)))
      (cond
       ((= syskind SYS_WIN16) :win16)
       ((= syskind SYS_WIN32) :win32)
       ((= syskind SYS_MAC) :mac)
       (t syskind)))))

Defines itypelib-syskind (links are to index).

<type library exports>+= (<-U) [<-D->]
itypelib-syskind

*

<type library constants>= (U->) [D->]
(wrap:c-constant SYS_WIN16 "SYS_WIN16" :integer)
(wrap:c-constant SYS_WIN32 "SYS_WIN32" :integer)
(wrap:c-constant SYS_MAC "SYS_MAC" :integer)

Defines SYS_MAC, SYS_WIN16, SYS_WIN32 (links are to index).

<type library attributes>+= (<-U) [<-D->]
(defun itypelib-major-version (lib)
  (with-tlibattr (attr lib) (tlibattr-major attr)))

Defines itypelib-major-version (links are to index).

<type library exports>+= (<-U) [<-D->]
itypelib-major-version

*

<type library attributes>+= (<-U) [<-D->]
(defun itypelib-minor-version (lib)
  (with-tlibattr (attr lib) (tlibattr-minor attr)))

Defines itypelib-minor-version (links are to index).

<type library exports>+= (<-U) [<-D->]
itypelib-minor-version

*

<type library attributes>+= (<-U) [<-D]
(defun itypelib-flags (lib)
  (with-tlibattr (attr lib)
    (let ((flags (tlibattr-flags attr))
          (lflags nil))
      (when (/= 0 (logand flags LIBFLAG_FRESTRICTED))
        (push :restricted lflags))
      (when (/= 0 (logand flags LIBFLAG_FHIDDEN)) (push :hidden lflags))
      (when (/= 0 (logand flags LIBFLAG_FCONTROL)) (push :control lflags))
      lflags)))

Defines itypelib-flags (links are to index).

<type library exports>+= (<-U) [<-D->]
itypelib-flags

*

<type library constants>+= (U->) [<-D]
(wrap:c-constant LIBFLAG_FRESTRICTED "LIBFLAG_FRESTRICTED" :integer)
(wrap:c-constant LIBFLAG_FCONTROL "LIBFLAG_FCONTROL" :integer)
(wrap:c-constant LIBFLAG_FHIDDEN "LIBFLAG_FHIDDEN" :integer)

Defines LIBFLAG_FCONTROL, LIBFLAG_FHIDDEN, LIBFLAG_FRESTRICTED (links are to index).

Type Information Entries

<type library entries>= (<-U) [D->]
(wrap:std-com-function base-itypelib-type-info "ITypeLib_GetTypeInfo"
                 ((:cptr "ITypeLib") :integer (:value (:cptr "ITypeInfo"))))

(defun itypelib-type-info (lib index)
  (wrap-itypeinfo (base-itypelib-type-info (itypelib-pointer lib) index)))

Defines base-itypelib-type-info, itypelib-type-info (links are to index).

<type library exports>+= (<-U) [<-D->]
itypelib-type-info

*

<type library entries>+= (<-U) [<-D->]
(wrap:c-function base-itypelib-type-info-count "ITypeLib_GetTypeInfoCount"
                 ((:cptr "ITypeLib")) :unsigned)

(defun itypelib-type-info-count (lib)
  (base-itypelib-type-info-count (itypelib-pointer lib)))

Defines base-itypelib-type-info-count, itypelib-type-info-count (links are to index).

<type library exports>+= (<-U) [<-D->]
itypelib-type-info-count

*

<type library entries>+= (<-U) [<-D->]
(wrap:std-com-function base-itypelib-type-info-of-guid
                       "ITypeLib_GetTypeInfoOfGuid"
                       ((:cptr "ITypeLib") (:cptr "GUID")
                        (:value (:cptr "ITypeInfo"))))

(defun itypelib-type-info-of-guid (lib guid)
  (let ((plib (itypelib-pointer lib)))
    (wrap-itypeinfo (base-itypelib-type-info-of-guid plib (guid-data guid)))))

Defines base-itypelib-type-info-of-guid, itypelib-type-info-of-guid (links are to index).

<type library exports>+= (<-U) [<-D->]
itypelib-type-info-of-guid

*

<C type declarations>+= (U->) [<-D->]
(wrap:declare-c-type typekind "TYPEKIND" :unsigned)

Defines typekind (links are to index).

<type library entries>+= (<-U) [<-D->]
(wrap:std-com-function base-itypelib-type-info-type "ITypeLib_GetTypeInfoType"
                       ((:cptr "ITypeLib") :integer (:value typekind)))

(defun itypelib-type-info-type (lib index)
  (let ((plib (itypelib-pointer lib)))
    (type-kind-to-keyword (base-itypelib-type-info-type plib index))))

Defines base-itypelib-type-info-type, itypelib-type-info-type (links are to index).

<type library exports>+= (<-U) [<-D->]
itypelib-type-info-type

*

<type library entries>+= (<-U) [<-D]
(wrap:std-com-function base-itypelib-is-name "ITypeLib_IsName"
                 ((:cptr "ITypeLib") (:cptr "WCHAR") :integer (:value bool)))

(defun itypelib-is-name (lib name)
  (let ((plib (itypelib-pointer lib))
        (wname (string-to-wide-string name)))
    (base-itypelib-is-name plib wname 0)))

Defines base-itypelib-is-name, itypelib-is-name (links are to index).

<type library exports>+= (<-U) [<-D->]
itypelib-is-name

Higher Level Functions

<higher level type library functions>= (<-U) [D->]
(defun itypelib-infos-of-kind (lib kind)
  (let ((val nil))
    (dotimes (i (itypelib-type-info-count lib) (nreverse val))
      (when (eq kind (itypelib-type-info-type lib i))
        (push (itypelib-type-info lib i) val)))))

Defines itypelib-infos-of-kind (links are to index).

<type library exports>+= (<-U) [<-D->]
itypelib-infos-of-kind

**** could avoid wrapping the info **** allow for multiple uses of name, check for constant

<higher level type library functions>+= (<-U) [<-D]
(defun itypelib-find-constant (lib name)
  (multiple-value-bind (info memid) (itypelib-find-name lib name)
    (when info
      (dotimes (i (itypeinfo-variable-count info))
        (with-vardesc (vd info i)
          (when (= (vardesc-memid vd) memid)
            (return (vardesc-value vd))))))))

Defines itypelib-find-constant (links are to index).

<type library exports>+= (<-U) [<-D]
itypelib-find-constant

Type Information

<type information>= (<-U)
(export '(<type information exports>))
<containing type library>
<type information documentation>
<type information attributes>
<type information function descriptions>
<type information member IDs from names>
<type information implementation type flags>
<type information names>
<type information referenced types>
<type information variable descriptions>
<higher level type information functions>

Containing Type Library

<containing type library>= (<-U)
(wrap:std-com-function base-itypeinfo-type-lib
                       "ITypeInfo_GetContainingTypeLib"
                       ((:cptr "ITypeInfo") (:value (:cptr "ITypeLib"))
                        (:cptr (:unsigned "int"))))

(defun itypeinfo-type-lib (info)
   (let* ((pti (itypeinfo-pointer info))
          (pidx (make-c-uint))
          (lib (system:without-interrupts
                (wrap-itypelib (base-itypeinfo-type-lib pti pidx)))))
     (values lib (get-c-uint pidx))))

Defines base-itypeinfo-type-lib, itypeinfo-type-lib (links are to index).

<type information exports>= (<-U) [D->]
itypeinfo-type-lib

Documentation

<type information documentation>= (<-U)
(wrap:std-com-function base-itypeinfo-documentation
                       "ITypeInfo_GetDocumentation"
                       ((:cptr "ITypeInfo") :integer
                        (:cptr "BSTR" t) (:cptr "BSTR" t)
                        (:cptr "long" t) (:cptr "BSTR" t)))

(defun itypeinfo-documentation (info &optional index all)
  (let ((i (if index index MEMBERID_NIL))
        (ptr (itypeinfo-pointer info)))
    (get-documentation #'base-itypeinfo-documentation ptr i all)))

(defun itypeinfo-name (info)
  (let ((ptr (itypeinfo-pointer info)))
    (get-documentation #'base-itypeinfo-documentation ptr MEMBERID_NIL nil)))

Defines base-itypeinfo-documentation, itypeinfo-documentation, itypeinfo-name (links are to index).

<type information exports>+= (<-U) [<-D->]
itypeinfo-documentation itypeinfo-name

Type Information Attributes

<type information attributes>= (<-U) [D->]
(wrap:std-com-function get-typeattr "ITypeInfo_GetTypeAttr"
                       ((:cptr "ITypeInfo") (:value (:cptr "TYPEATTR"))))

(wrap:c-function release-typeattr "ITypeInfo_ReleaseTypeAttr"
                 ((:cptr "ITypeInfo") (:cptr "TYPEATTR")) :void)

Defines get-typeattr, release-typeattr (links are to index).

<type information attributes>+= (<-U) [<-D->]
(wrap:c-pointer "TYPEATTR"
                (:get typeattr-lcid "lcid" :integer)
                (:get typeattr-kind "typekind" :integer)
                (:get typeattr-cfuncs "cFuncs" :integer)
                (:get typeattr-cvars "cVars" :integer)
                (:get typeattr-cimpltypes "cImplTypes" :integer)
                (:get typeattr-flags "wTypeFlags" :integer)
                (:get typeattr-major "wMajorVerNum" :integer)
                (:get typeattr-minor "wMinorVerNum" :integer)
                (:get typeattr-alias "tdescAlias.hreftype" :integer)
                (:get typeattr-idlinfo "idldescType.wIDLFlags" :integer))

(wrap:c-lines "
static void GetTypeAttrGUID(TYPEATTR *pta, GUID *pid)
{
  *pid = pta->guid;
}")
(wrap:c-function typeattr-get-guid "GetTypeAttrGUID"
                 ((:cptr "TYPEATTR") (:cptr "GUID")) :void)

Defines typeattr-alias, typeattr-cfuncs, typeattr-cimpltypes, typeattr-cvars, typeattr-flags, typeattr-get-guid, typeattr-idlflags, typeattr-kind, typeattr-lcid, typeattr-major, typeattr-minor (links are to index).

<type information attributes>+= (<-U) [<-D->]
(defmacro with-typeattr ((asym info) &body body)
  (let ((psym (gensym)))
    `(system:without-interrupts
      (let* ((,psym (itypeinfo-pointer ,info))
             (,asym (get-typeattr ,psym)))
        (unwind-protect
            (progn ,@body)
          (release-typeattr ,psym ,asym))))))

Defines with-typeattr (links are to index).

<type information attributes>+= (<-U) [<-D->]
(defun itypeinfo-guid (info)
  (with-typeattr (attr info)
    (let ((guid (make-guid-data)))
      (typeattr-get-guid attr guid)
      (make-guid guid))))

Defines itypeinfo-guid (links are to index).

<type information exports>+= (<-U) [<-D->]
itypeinfo-guid

*

<type information attributes>+= (<-U) [<-D->]
(defun itypeinfo-lcid (info)
  (with-typeattr (attr info) (typeattr-lcid attr)))

Defines itypeinfo-lcid (links are to index).

<type information exports>+= (<-U) [<-D->]
itypeinfo-lcid

*

<type information constants>= (U->) [D->]
(wrap:c-constant TKIND_ENUM "TKIND_ENUM" :integer)
(wrap:c-constant TKIND_RECORD "TKIND_RECORD" :integer)
(wrap:c-constant TKIND_MODULE "TKIND_MODULE" :integer)
(wrap:c-constant TKIND_INTERFACE "TKIND_INTERFACE" :integer)
(wrap:c-constant TKIND_DISPATCH "TKIND_DISPATCH" :integer)
(wrap:c-constant TKIND_COCLASS "TKIND_COCLASS" :integer)
(wrap:c-constant TKIND_ALIAS "TKIND_ALIAS" :integer)
(wrap:c-constant TKIND_UNION "TKIND_UNION" :integer)

Defines TKIND_ALIAS, TKIND_COCLASSt, TKIND_DISPATCH, TKIND_ENUM, TKIND_INTERFACE, TKIND_MODULE, TKIND_RECORD, TKIND_UNION (links are to index).

<type information attributes>+= (<-U) [<-D->]
(defun type-kind-to-keyword (kind)
  (cond
   ((= kind TKIND_ENUM) :enum)
   ((= kind TKIND_RECORD) :record)
   ((= kind TKIND_MODULE) :module)
   ((= kind TKIND_INTERFACE) :interface)
   ((= kind TKIND_DISPATCH) :dispatch)
   ((= kind TKIND_COCLASS) :coclass)
   ((= kind TKIND_ALIAS) :alias)
   ((= kind TKIND_UNION) :union)
   (t :unknown)))

Defines type-kind-to-keyword (links are to index).

<type information attributes>+= (<-U) [<-D->]
(defun itypeinfo-kind (info)
  (with-typeattr (attr info) (type-kind-to-keyword (typeattr-kind attr))))

Defines itypeinfo-kind (links are to index).

<type information exports>+= (<-U) [<-D->]
itypeinfo-kind

*

<type information attributes>+= (<-U) [<-D->]
(defun itypeinfo-function-count (info)
  (with-typeattr (attr info) (typeattr-cfuncs attr)))

Defines itypeinfo-function-count (links are to index).

<type information exports>+= (<-U) [<-D->]
itypeinfo-function-count

*

<type information attributes>+= (<-U) [<-D->]
(defun itypeinfo-variable-count (info)
  (with-typeattr (attr info) (typeattr-cvars attr)))

Defines itypeinfo-variable-count (links are to index).

<type information exports>+= (<-U) [<-D->]
itypeinfo-variable-count

*

<type information attributes>+= (<-U) [<-D->]
(defun itypeinfo-implementation-count (info)
  (with-typeattr (attr info) (typeattr-cimpltypes attr)))

Defines itypeinfo-implementation-count (links are to index).

<type information exports>+= (<-U) [<-D->]
itypeinfo-implementation-count

*

<type information constants>+= (U->) [<-D->]
(wrap:c-constant TYPEFLAG_FAPPOBJECT "TYPEFLAG_FAPPOBJECT" :integer)
(wrap:c-constant TYPEFLAG_FCANCREATE "TYPEFLAG_FCANCREATE" :integer)
(wrap:c-constant TYPEFLAG_FLICENSED "TYPEFLAG_FLICENSED" :integer)
(wrap:c-constant TYPEFLAG_FHIDDEN "TYPEFLAG_FHIDDEN" :integer)
(wrap:c-constant TYPEFLAG_FCONTROL "TYPEFLAG_FCONTROL" :integer)
(wrap:c-constant TYPEFLAG_FDUAL "TYPEFLAG_FDUAL" :integer)
(wrap:c-constant TYPEFLAG_FNONEXTENSIBLE "TYPEFLAG_FNONEXTENSIBLE" :integer)
(wrap:c-constant TYPEFLAG_FOLEAUTOMATION "TYPEFLAG_FOLEAUTOMATION" :integer)
(wrap:c-constant TYPEFLAG_FRESTRICTED "TYPEFLAG_FRESTRICTED" :integer)
(wrap:c-constant TYPEFLAG_FAGGREGATABLE "TYPEFLAG_FAGGREGATABLE" :integer)
(wrap:c-constant TYPEFLAG_FREPLACEABLE "TYPEFLAG_FREPLACEABLE" :integer)
(wrap:c-constant TYPEFLAG_FDISPATCHABLE "TYPEFLAG_FDISPATCHABLE" :integer)

Defines TYPEFLAG_FAGGREGATABLE, TYPEFLAG_FAPPOBJECT, TYPEFLAG_FCANCREATE, TYPEFLAG_FCONTROL, TYPEFLAG_FDISPATCHABLE, TYPEFLAG_FDUAL, TYPEFLAG_FHIDDEN, TYPEFLAG_FLICENSED, TYPEFLAG_FNONEXTENSIBLE, TYPEFLAG_FOLEAUTOMATION, TYPEFLAG_FREPLACEABLE, TYPEFLAG_FRESTRICTED (links are to index).

<type information attributes>+= (<-U) [<-D->]
(defun itypeinfo-flags (info)
  (with-typeattr (attr info)
    (let ((flags (typeattr-flags attr))
          (lflags nil))
      (when (/= 0 (logand flags TYPEFLAG_FAPPOBJECT)) (push :appobject lflags))
      (when (/= 0 (logand flags TYPEFLAG_FCANCREATE)) (push :cancreate lflags))
      (when (/= 0 (logand flags TYPEFLAG_FLICENSED)) (push :licensed lflags))
      (when (/= 0 (logand flags TYPEFLAG_FHIDDEN)) (push :hidden lflags))
      (when (/= 0 (logand flags TYPEFLAG_FCONTROL)) (push :control lflags))
      (when (/= 0 (logand flags TYPEFLAG_FDUAL)) (push :dual lflags))
      (when (/= 0 (logand flags TYPEFLAG_FNONEXTENSIBLE))
        (push :nonextensible lflags))
      (when (/= 0 (logand flags TYPEFLAG_FOLEAUTOMATION))
        (push :oleautomation lflags))
      (when (/= 0 (logand flags TYPEFLAG_FRESTRICTED))
        (push :restricted lflags))
      (when (/= 0 (logand flags TYPEFLAG_FAGGREGATABLE))
        (push :aggregatable lflags))
      (when (/= 0 (logand flags TYPEFLAG_FREPLACEABLE))
        (push :replaceable lflags))
      (when (/= 0 (logand flags TYPEFLAG_FDISPATCHABLE))
        (push :dispatchable lflags))
      lflags)))

Defines itypeinfo-flags (links are to index).

<type information exports>+= (<-U) [<-D->]
itypeinfo-flags

*

<type information attributes>+= (<-U) [<-D->]
(defun itypeinfo-major (info)
  (with-typeattr (attr info) (typeattr-major attr)))

Defines itypeinfo-major (links are to index).

<type information exports>+= (<-U) [<-D->]
itypeinfo-major

*

<type information attributes>+= (<-U) [<-D->]
(defun itypeinfo-minor (info)
  (with-typeattr (attr info) (typeattr-minor attr)))

Defines itypeinfo-minor (links are to index).

<type information exports>+= (<-U) [<-D->]
itypeinfo-minor

*

<type information attributes>+= (<-U) [<-D->]
(defun itypeinfo-alias (info)
  (with-typeattr (attr info) (typeattr-alias attr)))

Defines itypeinfo-alias (links are to index).

<type information exports>+= (<-U) [<-D->]
itypeinfo-alias

*

<type information attributes>+= (<-U) [<-D]
;;**** decode this??
(defun itypeinfo-idlinfo (info)
  (with-typeattr (attr info) (typeattr-idlinfo attr)))

Defines itypeinfo-idlinfo (links are to index).

<type information exports>+= (<-U) [<-D->]
itypeinfo-idlinfo

Function Descriptions

<type information function descriptions>= (<-U) [D->]
(wrap:std-com-function get-funcdesc "ITypeInfo_GetFuncDesc"
                       ((:cptr "ITypeInfo") :integer
                        (:value (:cptr "FUNCDESC"))))

(wrap:c-function release-funcdesc "ITypeInfo_ReleaseFuncDesc"
                 ((:cptr "ITypeInfo") (:cptr "FUNCDESC")) :void)

Defines get-funcdesc, release-funcdesc (links are to index).

<type information function descriptions>+= (<-U) [<-D->]
(defmacro with-funcdesc ((fdsym info index) &body body)
  (let ((psym (gensym)))
    `(system:without-interrupts
      (let* ((,psym (itypeinfo-pointer ,info))
             (,fdsym (get-funcdesc ,psym ,index)))
        (unwind-protect
            (progn ,@body)
          (release-funcdesc ,psym ,fdsym))))))

Defines with-funcdesc (links are to index).

**** decode vt's into keyword or symbol???

<type information function descriptions>+= (<-U) [<-D->]
(wrap:c-pointer "FUNCDESC"
                (:get funcdesc-memid "memid" :integer)
                (:get funcdesc-params "lprgelemdescParam" (:cptr "ELEMDESC"))
                (:get base-funcdesc-funckind "funckind" :integer)
                (:get base-funcdesc-invkind "invkind" :integer)
                (:get funcdesc-cparams "cParams" :integer)
                (:get funcdesc-cparamsopt "cParamsOpt" :integer)
                (:get funcdesc-flags "wFuncFlags" :integer)
                (:get funcdesc-valtype "elemdescFunc.tdesc.vt" :integer))

(wrap:c-pointer "ELEMDESC" (:get elemdesc-valtype "tdesc.vt" :integer))

Defines base-funcdesc-funckind, base-funcdesc-invkind, funcdesc-cparams, funcdesc-cparamsopt, funcdesc-flags, funcdesc-memid, funcdesc-params, funcdesc-valtype (links are to index).

<type information constants>+= (U->) [<-D->]
(wrap:c-constant FUNC_PUREVIRTUAL "FUNC_PUREVIRTUAL" :integer)
(wrap:c-constant FUNC_VIRTUAL "FUNC_VIRTUAL" :integer)
(wrap:c-constant FUNC_NONVIRTUAL "FUNC_NONVIRTUAL" :integer)
(wrap:c-constant FUNC_STATIC "FUNC_STATIC" :integer)
(wrap:c-constant FUNC_DISPATCH "FUNC_DISPATCH" :integer)

Defines FUNC_DISPATCH, FUNC_NONVIRTUAL, FUNC_PUREVIRTUAL, FUNC_STATIC, FUNC_VIRTUAL (links are to index).

<type information function descriptions>+= (<-U) [<-D->]
(defun funcdesc-funckind (fd)
  (let ((funckind (base-funcdesc-funckind fd)))
    (cond
     ((= funckind FUNC_PUREVIRTUAL) :purevirtual)
     ((= funckind FUNC_VIRTUAL) :virtual)
     ((= funckind FUNC_NONVIRTUAL) :nonvirtual)
     ((= funckind FUNC_STATIC) :static)
     ((= funckind FUNC_DISPATCH) :dispatch)
     (t :unknown))))

Defines funcdesc-funckind (links are to index).

<type information constants>+= (U->) [<-D->]
(wrap:c-constant INVOKE_FUNC "INVOKE_FUNC" :integer)
(wrap:c-constant INVOKE_PROPERTYGET "INVOKE_PROPERTYGET" :integer)
(wrap:c-constant INVOKE_PROPERTYPUT "INVOKE_PROPERTYPUT" :integer)
(wrap:c-constant INVOKE_PROPERTYPUTREF "INVOKE_PROPERTYPUTREF" :integer)

Defines INVOKE_FUNC, INVOKE_PROPERTYGET, INVOKE_PROPERTYPUT, INVOKE_PROPERTYPUTREF (links are to index).

<type information function descriptions>+= (<-U) [<-D->]
(defun funcdesc-invkind (fd)
  (let ((invkind (base-funcdesc-invkind fd)))
    (cond
     ((= invkind INVOKE_FUNC) :method)
     ((= invkind INVOKE_PROPERTYGET) :get)
     ((= invkind INVOKE_PROPERTYPUT) :put)
     ((= invkind INVOKE_PROPERTYPUTREF) :putref)
     (t :unknown))))

Defines funcdesc-invkind (links are to index).

<type information function descriptions>+= (<-U) [<-D]
(defun itypeinfo-funcdesc (info i)
  (with-funcdesc (fd info i)
    (let ((memid (funcdesc-memid fd))
          (cparams (funcdesc-cparams fd)))
      (list memid
            (let ((ed (funcdesc-params fd))
                  (val nil))
              (dotimes (i cparams (nreverse val))
                (push (elemdesc-valtype ed i) val)))
            (funcdesc-funckind fd)
            (funcdesc-invkind fd)
            cparams
            (funcdesc-cparamsopt fd)
            (funcdesc-valtype fd)
            (funcdesc-flags fd)
            (itypeinfo-names info memid (+ cparams 1))))))