Shared Libraries for XLISP-STAT

Luke Tierney
1998/03/27

Table of Contents

Introduction

This report presents a simple shared library system for XLISP-STAT built on the dlfcn core. The system consists of a low level implemented in C functions and a top level in Lisp. The C functions can be used to form different higher levels, including emulating the old call-cfun interface, but the low level deals directly with pointers and must be used with caution.

The primary files in this implementation are xlshlib.c, xlshlib.h, and shlib.lsp. But a number of additional minor changes are also needed, so I'm making this available as a snapshot of the source tree. This snapshot includes Macintosh project files for CodeWarrior Pro 2.

Two larger examples of using this mechanism are also available. One is a regular espressions library, the other a socket library.

Low Level

The low level is implemented as a number of routines in xlshlib.c that are installed as SUBRs in the function table. The corresponding symbols are all installed as internal symbols in the SHARED-LIBRARY package with nickname SHLIB. To support hiding these routines from public use, since they are quite dangerous, the mechanism for entering symbols from the table has been changed to allow unexported symbols in new packages to be specified (a change that was overdue anyway).

Interface to dlfcn

The low level consists of an interface to the dlfcn routines and some utility functions. It is only available when SHAREDLIBS is defined.

<xlshlib.c>=

#include "xlisp.h"
#ifdef SHAREDLIBS
#include <dlfcn.h>
<xlshlib.c macros>
<xlshlib.c body>
#endif /* SHAREDLIBS */

Generic pointers are represented using the new native pointer representation. Errors are signaled by

<xlshlib.c body>= (<-U) [D->]
static void shlib_error()
{
  char *str = dlerror();
  xlfail(str != NULL ? str : "unknown shared library error");
}
Defines shlib_error (links are to index).

A shared library is opened by calling shlib-open with the path name as its argument. This Lisp function is implemented internally by xshlibopen, which calls dlopen with mode RTLD_NOW. This should fail if there are unresolved references instead of causing a core dump later. Some systems ignore the mode (Mac and Windows) and those act like RTLD_NOW anyway as far as I can tell. If the library can't be opened an error is signaled. If the library is opened successfully, its internal reference handle, a void * pointer, is returned as a fixnum.

<xlshlib.c body>+= (<-U) [<-D->]
/* SHLIB-OPEN path */
LVAL xshlibopen()
{
  char *name;
  void *handle;
  name = getstring(xlgastring());
  xllastarg();
  if ((handle = dlopen(name, RTLD_NOW)) == NULL)
    shlib_error();
  return newnatptr(handle, NIL);
}
Defines shlib-open, xshlibopen (links are to index).

<funtab additions>= [D->]
{   "SHARED-LIBRARY::SHLIB-OPEN",         S, xshlibopen      },

The function shlib-symaddr, internally xshlibsymaddr, uses dlsym to look up a symbol in a specified library. By default, an error is signaled if the symbol is not found. To allow searching for variants (e.g. foo, foo_, _foo) an optional argument of NIL causes NIL to be returned if the symbol is not found. The address is returned as a fixnum. [On Windows a function that looks up the address by ordinal value is probably also needed.] The library is protected in the returned function pointer.

<xlshlib.c body>+= (<-U) [<-D->]
/* SHLIB-SYMADDR lib name &optional error */
LVAL xshlibsymaddr()
{
  void *val;
  LVAL lib = xlganatptr();
  void *handle = getnpaddr(lib);
  char *name = getstring(xlgastring());
  int err = moreargs() ? null(xlgetarg()) : TRUE;
  xllastarg();
  if ((val = dlsym(handle, name)) == NULL) {
    if (err)
      shlib_error();
    else
      return NIL;
  }
  return newnatptr(val, lib);
}
Defines shlib-symaddr, xshlibsymaddr (links are to index).

<funtab additions>+= [<-D->]
{   "SHARED-LIBRARY::SHLIB-SYMADDR",      S, xshlibsymaddr   },

A shared library is closed by shlib-close (xshlibclose), which calls dlclose; again, an error is signaled on failure.

<xlshlib.c body>+= (<-U) [<-D->]
/* SHLIB-CLOSE lib */
LVAL xshlibclose()
{
  void *lib = getnpaddr(xlganatptr());
  xllastarg();
  if (dlclose(lib) == -1)
    shlib_error();
  return NIL;
}
Defines shlib-close, xdlclose (links are to index).

<funtab additions>+= [<-D->]
{   "SHARED-LIBRARY::SHLIB-CLOSE",        S, xshlibclose     },

Some Utility Functions

The function call-by-address allows us to use a function address. The arguments and return value are assumed to be pointers of type void *. The implementation in xshlibcalladdr uses a big switch with a limit of MAX_CALLADDR_ARGS arguments.

<xlshlib.c body>+= (<-U) [<-D->]
#define MAX_CALLADDR_ARGS 16

/* CALL-BY-ADDRESS &rest args */
LVAL xshlibcalladdr()
{
  void *(*f)() = (void *(*)()) getnpaddr(xlganatptr());
  void *a[MAX_CALLADDR_ARGS];
  int n, i;

  if (xlargc > MAX_CALLADDR_ARGS)
    xltoomany();

  <read arguments for call-by-address>
  
  switch (n) {
  case 0: return cvvoidptr(f());
  case 1: return cvvoidptr(f(a[0]));
  case 2: return cvvoidptr(f(a[0],a[1]));
  case 3: return cvvoidptr(f(a[0],a[1],a[2]));
  case 4: return cvvoidptr(f(a[0],a[1],a[2],a[3]));
  case 5: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4]));
  case 6: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5]));
  case 7: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6]));
  case 8: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]));
  case 9: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]));
  case 10: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
                              a[9]));
  case 11: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
                              a[9],a[10]));
  case 12: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
                              a[9],a[10],a[11]));
  case 13: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
                              a[9],a[10],a[11],a[12]));
  case 14: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
                              a[9],a[10],a[11],a[12],a[13]));
  case 15: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
                              a[9],a[10],a[11],a[12],a[13],a[14]));
  case 16: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
                              a[9],a[10],a[11],a[12],a[13],a[14],a[15]));
  default: xlfail("too many arguments"); return NIL;
  }
}
Defines call-by-address, xcalladdr (links are to index).

<funtab additions>+= [<-D->]
{   "SHARED-LIBRARY::CALL-BY-ADDRESS",    S, xshlibcalladdr  },

The macro cvvoidptr converts the return value to a native pointer representation.

<xlshlib.c macros>= (<-U) [D->]
#define cvvoidptr(x) newnatptr(x, NIL)
Defines cvvoidptr (links are to index).

Arguments can be either native pointers or FIXNUM's.

<read arguments for call-by-address>= (<-U U->)
for (n = xlargc, i = 0; i < n; i++) {
  LVAL arg = xlgetarg();
  if (fixp(arg))
    a[i] = (void *) getfixnum(arg);
  else if (natptrp(arg))
    a[i] = getnpaddr(arg);
  else
    xlbadtype(arg);
}

For MS Windows we probably need a separate function for each calling convention. ****

<xlshlib.c body>+= (<-U) [<-D->]
#ifdef _Windows
typedef void * __stdcall (*stdfun0)(void);
typedef void * __stdcall (*stdfun1)(void *);
typedef void * __stdcall (*stdfun2)(void *, void *);
typedef void * __stdcall (*stdfun3)(void *, void *, void *);
typedef void * __stdcall (*stdfun4)(void *, void *, void *, void *);
typedef void * __stdcall (*stdfun5)(void *, void *, void *, void *, \
 void *);
typedef void * __stdcall (*stdfun6)(void *, void *, void *, void *, \
 void *, void *);
typedef void * __stdcall (*stdfun7)(void *, void *, void *, void *, \
 void *, void *, void *);
typedef void * __stdcall (*stdfun8)(void *, void *, void *, void *, \
 void *, void *, void *, void *);
typedef void * __stdcall (*stdfun9)(void *, void *, void *, void *, \
 void *, void *, void *, void *, void *);
typedef void * __stdcall (*stdfun10)(void *, void *, void *, void *, \
 void *, void *, void *, void *, void *, void *);
typedef void * __stdcall (*stdfun11)(void *, void *, void *, void *, \
 void *, void *, void *, void *, void *, void *, void *);
typedef void * __stdcall (*stdfun12)(void *, void *, void *, void *, \
 void *, void *, void *, void *, void *, void *, void *, void *);
typedef void * __stdcall (*stdfun13)(void *, void *, void *, void *, \
 void *, void *, void *, void *, void *, void *, void *, void *, \
 void *);
typedef void * __stdcall (*stdfun14)(void *, void *, void *, void *, \
 void *, void *, void *, void *, void *, void *, void *, void *, \
 void *, void *);
typedef void * __stdcall (*stdfun15)(void *, void *, void *, void *, \
 void *, void *, void *, void *, void *, void *, void *, void *, \
 void *, void *, void *);
typedef void * __stdcall (*stdfun16)(void *, void *, void *, void *, \
 void *, void *, void *, void *, void *, void *, void *, void *, \
 void *, void *, void *, void *);
                               
LVAL xshlibstdcalladdr()
{
  void *f = getnpaddr(xlganatptr());
  void *a[MAX_CALLADDR_ARGS];
  int n, i;

  if (xlargc > MAX_CALLADDR_ARGS)
    xltoomany();

  <read arguments for call-by-address>
  
  switch (n) {
  case 0: return cvvoidptr(((stdfun0) f)());
  case 1: return cvvoidptr(((stdfun1) f)(a[0]));
  case 2: return cvvoidptr(((stdfun2) f)(a[0],a[1]));
  case 3: return cvvoidptr(((stdfun3) f)(a[0],a[1],a[2]));
  case 4: return cvvoidptr(((stdfun4) f)(a[0],a[1],a[2],a[3]));
  case 5: return cvvoidptr(((stdfun5) f)(a[0],a[1],a[2],a[3],
                                         a[4]));
  case 6: return cvvoidptr(((stdfun6) f)(a[0],a[1],a[2],a[3],
                                         a[4], a[5]));
  case 7: return cvvoidptr(((stdfun7) f)(a[0],a[1],a[2],a[3],
                                         a[4],a[5],a[6]));
  case 8: return cvvoidptr(((stdfun8) f)(a[0],a[1],a[2],a[3],
                                         a[4],a[5],a[6],a[7]));
  case 9: return cvvoidptr(((stdfun9) f)(a[0],a[1],a[2],a[3],
                                         a[4],a[5],a[6],a[7],
                                         a[8]));
  case 10: return cvvoidptr(((stdfun10) f)(a[0],a[1],a[2],a[3],
                                           a[4],a[5],a[6],a[7],
                                           a[8],a[9]));
  case 11: return cvvoidptr(((stdfun11) f)(a[0],a[1],a[2],a[3],
                                           a[4],a[5],a[6],a[7],
                                           a[8],a[9],a[10]));
  case 12: return cvvoidptr(((stdfun12) f)(a[0],a[1],a[2],a[3],
                                           a[4],a[5],a[6],a[7],
                                           a[8],a[9],a[10],a[11]));
  case 13: return cvvoidptr(((stdfun13) f)(a[0],a[1],a[2],a[3],
                                           a[4],a[5],a[6],a[7],
                                           a[8],a[9],a[10],a[11],
                                           a[12]));
  case 14: return cvvoidptr(((stdfun14) f)(a[0],a[1],a[2],a[3],
                                           a[4],a[5],a[6],a[7],
                                           a[8],a[9],a[10],a[11],
                                           a[12],a[13]));
  case 15: return cvvoidptr(((stdfun15) f)(a[0],a[1],a[2],a[3],
                                           a[4],a[5],a[6],a[7],
                                           a[8],a[9],a[10],a[11],
                                           a[12],a[13],a[14]));
  case 16: return cvvoidptr(((stdfun16) f)(a[0],a[1],a[2],a[3],
                                           a[4],a[5],a[6],a[7],
                                           a[8],a[9],a[10],a[11],
                                           a[12],a[13],a[14],a[15]));
  default: xlfail("too many arguments"); return NIL;
  }
}
#endif
Defines stdcall-by-address, xstdcalladdr (links are to index).

<funtab additions>+= [<-D->]
{   "SHARED-LIBRARY::STDCALL-BY-ADDRESS",       S, xshlibstdcalladdr},

As a minimal test, use the file foo.c

<foo.c>=
#include <stdio.h>
void foo()
{
  stdputstr("Hello\n");
}
Defines foo (links are to index).

After creating the shared library foo.dll this produces

> (setf lib (shlib::shlib-open "foo.dll"))
#<Pointer: #7b0317c8>
> (setf foo (shlib::shlib-symaddr lib "foo"))
#<Pointer: #7afed01a>
> (shlib::call-by-address foo)
Hello
#<Pointer: #0>
I am using the .dll extension for shared libraries since Windows more or less insists on it. The Macintosh doesn't really have a preferred extension. UNIX is split between .sl (HPUX) and .so (more or less everyone else), but doesn't really care.

The existing function address-of can be used to obtain the addresses of Lisp objects. For Lisp vectors, the function array-data-address returns the address of the first vector data entry. Using this function may require a locking mechanism if I ever move to a setup where compaction is possible. ****

<xlshlib.c body>+= (<-U) [<-D->]
/* ARRAY-DATA-ADDRESS array */
LVAL xarraydata_addr()
{
  LVAL x = xlgetarg();
  xllastarg();

  switch (ntype(x)) {
  case DARRAY: x = getdarraydata(x); /* and drop through */
  case VECTOR:
  case STRING:
  case TVEC: return newnatptr(gettvecdata(x), x);
  default: return xlbadtype(x);
  }
}
Defines array-data-address, xarraydata_addr (links are to index).

<funtab additions>+= [<-D->]
{   "ARRAY-DATA-ADDRESS",                       S, xarraydata_addr },

Emulating the Old call-cfun

The functions defined so far allow us to reproduce the old call-cfun approach at the lisp level. This code emulates the Windows version where a library handle is needed. The file is oldcfun.lsp.

<oldcfun.lsp>=
(defpackage "SHARED-LIBRARY" (:use "XLISP") (:nicknames "SHLIB"))
(in-package "SHARED-LIBRARY")

<oldcfun.lsp body>

We need a function to copy lisp arguments to fresh typed vector arguments.

<oldcfun.lsp body>= (<-U) [D->]
(defun lisp-to-arg (x)
  (let* ((seq (if (sequencep x) x (list x)))
         (type (if (every #'integerp seq) '(vector c-long) '(vector c-double)))
         (val (coerce seq type)))
    (if (eq val x) (copy-seq val) val)))
Defines lisp-to-arg (links are to index).

To emulate the old behavior, after the call the arguments need to be coerced to lists.

<oldcfun.lsp body>+= (<-U) [<-D->]
(defun arg-to-lisp (x) (coerce x 'list))
Defines arg-to-lisp (links are to index).

The old-call-cfun is then

<oldcfun.lsp body>+= (<-U) [<-D]
(defun old-call-cfun (name lib &rest args)
  (let* ((fun-addr (shlib-symaddr lib name))
         (argvecs (mapcar #'lisp-to-arg args))
         (arg-addrs (mapcar #'array-data-address argvecs)))
    (apply #'call-by-address fun-addr arg-addrs)
    (mapcar #'arg-to-lisp argvecs)))
Defines arg-to-lisp, lisp-to-arg, old-call-cfun (links are to index).

Test code for this is in cfuntest.c.

<cfuntest.c>=
bar(n, x, sum)
     int *n;
     double *x, *sum;
{
  int i;

  for (i = 0, *sum = 0.0; i < *n; i++) {
    *sum += x[i];
  }
}
Defines bar (links are to index).

After creating the library, we can use it as

> (load "oldcfun")
; loading oldcfun.lsp
T
> (setf lib (shlib::shlib-open "cfuntest.dll"))
#<Pointer: #7b0317c8>
> (shlib::old-call-cfun "bar" lib 5 (float (iseq 1 5)) 0.0)
((5) (1.0 2.0 3.0 4.0 5.0) (15.0))

Other Calls

It should be possible to use call-by-address to call many other functions on most hardware. As long as calling conventions widen all arguments and return values to the size of a void * and all pointers have the same representation this should work. In particular, on Win32 stdcall-by-address conventions should be able to call most Win32 API functions. For example, to use GetSystemMetrics to compute the screen size you can use
> (setf user (shlib::shlib-open "user32.dll"))
#<Pointer: #bff60000>
> (setf gsm (shlib::shlib-symaddr user "GetSystemMetrics"))
#<Pointer: #bff6488b>
> (pointer-address (shlib::stdcall-by-address gsm 0))
800
> (pointer-address (shlib::stdcall-by-address gsm 1))
600

There are some systems where different pointers have different representations. For example, I seem to remember that Cray uses a special representation for char * pointers. I think this means the array-data-access function should be more careful about the pointer type it converts to long, but I'm not sure.

Lisp Functions

Internal Lisp functions are represented as SUBR nodes that contain a pointer to a function of type LVAL (*)(void), a flag indicating whether the function returns multiple values, and an index into the static function table. The assumption is that these nodes only refer to functions known at compile time and installed in the function table. I believe the index is only used in two places, printing of SUBR nodes and restoring SUBR nodes when loading a save workspace.

Addresses of dynamically loaded functions can be installed in a new SUBR node with make-subr (xmakesubr). The offset used is zero. This installs a valid SUBR when a workspace is reloaded (but there may be a problem if this is a multiple value subr ****). The optional second argument to make-subr specifies whether the function returns multiple values; the default is NIL. [Storing a pointer in a SUBR does not currently store the protected value of the pointer, only the pointer address. the SUBR note should be changed to allow this protected value, i.e. the shared library handle, to be stored. Then the shared library can be safely closed when all Lisp references to it have disappeared, for example using the new finalization mechanism.]

<xlshlib.c body>+= (<-U) [<-D->]
/* MAKE-SUBR addr &optional mulvalp */
LVAL xmakesubr()
{
  LVAL val;
  LVAL (*fun)(void) = (LVAL (*)(void)) getnpaddr(xlganatptr());
  int mv = moreargs() ? (null(xlgetarg()) ? FALSE : TRUE) : FALSE;
  xllastarg();
  val = cvsubr(fun, SUBR, 0);
  setmulvalp(val, mv);
  return val;
}
Defines make-subr, xmakesubr (links are to index).

<funtab additions>+= [<-D->]
{   "SHARED-LIBRARY::MAKE-SUBR",          S, xmakesubr       },

Some useful macros:

<xlshlib.c macros>+= (<-U) [<-D]
#define setsubr(x,v) getsubr(x)=(v)
#define setoffset(x,v) getoffset(x)=(v)
#define xlgasubr()    (testarg(typearg(subrp)))
Defines setoffset, setsubr, xlgasubr (links are to index).

When a library is unloaded any SUBRs allocated for functions in the library should be invalidated with clear-subr (xclearsubr).

<xlshlib.c body>+= (<-U) [<-D->]
LOCAL LVAL errsubr() { xlfail("SUBR not available"); return NIL; }

/* CLEAR-SUBR subr */
LVAL xclearsubr()
{
  LVAL x = xlgasubr();
  xllastarg();
  setsubr(x, errsubr);
  setoffset(x, 0);
  setmulvalp(x, FALSE);
  return NIL;
}
Defines clear-subr, xclearsubr (links are to index).

<funtab additions>+= [<-D->]
{   "SHARED-LIBRARY::CLEAR-SUBR",         S, xclearsubr      },

The test example is in file baz.c.

<baz.c>=
#include "xlisp.h"

LVAL baz()
{
  FIXTYPE x, y;
  x = getfixnum(xlgafixnum());
  y = getfixnum(xlgafixnum());
  xllastarg();
  return cvfixnum(x + y);
}
Defines baz (links are to index).

Running this produces

> (setf lib (shlib::shlib-open "baz.dll"))
#<Pointer: #7b0317c8>
> (setf (symbol-function 'baz)
        (shlib::make-subr (shlib::shlib-symaddr lib "baz")))
#<Subr: #400be378>
> (baz 1 2)
3
> (shlib::clear-subr #'baz)
NIL
> (baz 1 2)
Error: SUBR not available

Higher Level

Shared libraries are used to provide collections of functionality---functions, constants and variables. Let's call such a collection module. The name is overused but I can't think of anything better for now. Here are a couple of things a module support system should do: There seem to be two approaches, exemplified by Tcl and Python. Both have a single initialization routine in each module that is called at load time. In Tcl, the initialization routine makes various function calls to register functions and the like. In Python, the initialization routine typically only registers a static table of functin definition information. The Tcl approah is more flexible, but this flexibility makes it harder to fit into an efficient static loading framework and to provide a reflection mechanism. I am therefore using an approach more like the Python model.

Versioning

The version-checking approach is derived from the internal system used by the Macintosh for code fragments. It may be a bit more elaborate than needed but seems useful.

Version information is represented by a structure

<version_info structure>= (U->)
struct version_info { long current, oldest; };
Defines version_info (links are to index).

The current field represents the primary version number; a request and an implementation are compatible if they have the same current version numbers. The oldest field represents the oldest version that is compatible. If the current request is newer than the implementation, but the current implementation is greater than or equal to the oldest version compatible with the request, then the versions are compatible. If the current request is less than the current implementation but the current request is greater than or equal to the oldest version compatible with the implementation, then the versions are compatible. Otherwise, the versions are not compatible. The function check_version implements this comparison.

<check_version function>= (U->)
static int check_version(struct version_info *req, struct version_info *imp)
{
  if (req->current == imp->current)
    return TRUE;
  else if (req->current > imp->current)
    return imp->current >= req->oldest ? TRUE : FALSE;
  else
    return req->current >= imp->oldest ? TRUE : FALSE;
}
Defines check_version (links are to index).

The version fields can be any integers, but I will use the convention that a version has a major and minor component. The macro MAKEVERSION constructs a version number from major and minor components.

<version definitions>= (U-> U->) [D->]
#define MAKEVERSION(major,minor) ((1L<<16) * major + minor)
Defines MAKEVERSION (links are to index).

This versioning system will be used for two purposes: to allow a module to contain version information and to distinguish versions of the module support system itself in case that system should change in an incompatible way. The current module system is 0.1 but it is compatible with the initial module system version 0.0. This is encoded in the macro XLSHLIB_SYSVERSION in the xlshlib.h include file used by modules and in the system implementation file xlshlib.c

<version definitions>+= (U-> U->) [<-D->]
#define XLSHLIB_SYSVERSION {MAKEVERSION(0,1),MAKEVERSION(0,0)}
Defines XLSHLIB_SYSVERSION (links are to index).

In the system implementation, this macro is used as the value of the static variable

<defsysversion variable definition>= (U->)
static struct version_info defsysversion = XLSHLIB_SYSVERSION;
Defines defsysversion (links are to index).

In the header file, this macro is used to form a macro for setting module version information in the module structure.

<version definitions>+= (U-> U->) [<-D]
#define XLSHLIB_VERSION_INFO(maj_cur,min_cur,maj_old,min_old) \
  XLSHLIB_SYSVERSION, \
  {MAKEVERSION(maj_cur,min_cur),MAKEVERSION(maj_old,min_old)}
Defines XLSHLIB_VERSION_INFO (links are to index).

Initialization

In my framework, the initialization routine for a module foo is named foo__init and is declared as
xlshlib_modinfo_t *foo__init(void);
The xlshlib_modinfo_t structure is defined by

<xlshlib_modinfo_t structure>= (U->)
typedef struct {
  struct version_info sysversion;
  struct version_info modversion;
  FUNDEF *funs;
  FIXCONSTDEF *fixconsts;
  FLOCONSTDEF *floconsts;
  STRCONSTDEF *strconsts;
  ULONGCONSTDEF *ulongconsts;
} xlshlib_modinfo_t;
Defines xlshlib_modinfo_t (links are to index).

This allows SUBR's and several kinds of simple constants to be specified.

The FUNDEF structure is the standard structure used in the internal function table. The constant definition structures are

<constant definition structures>= (U->)
typedef struct { char *name; FIXTYPE val; } FIXCONSTDEF;
typedef struct { char *name; FLOTYPE val; } FLOCONSTDEF;
typedef struct { char *name; char *val; } STRCONSTDEF;
typedef struct { char *name; unsigned long val; } ULONGCONSTDEF;
Defines FIXCONSTDEF, FLOCONSTDEF, STRCONSTDEF (links are to index).

The relevant declarations are contained in the header file xlshlib.h.

<xlshlib.h>=
#ifdef _Windows
#define XLGLOBAL __declspec(dllimport)
#endif

#include "xlisp.h"
#define MVSUBR (SUBR + TYPEFIELD + 1)

<version definitions>
<module table definitions>

with

<module table definitions>= (<-U U->)
<version_info structure>
<constant definition structures>
<xlshlib_modinfo_t structure>

As an example, suppose we have a module mymodule that implements a function fred. The module is in the file modex.c, which starts with

<modex.c>= [D->]
#include "xlshlib.h"

static LVAL fred()
{
  FIXTYPE x = getfixnum(xlgafixnum());
  FIXTYPE y = getfixnum(xlgafixnum());
  xllastarg();
  return cvfixnum(x + y);
}
Defines fred (links are to index).

The function table for this single SUBR is

<modex.c>+= [<-D->]
static FUNDEF myfuns[] = {
  { "FOO:FRED", SUBR, fred },
  { NULL, 0, NULL }
};
Defines myfuns (links are to index).

The package specification FOO causes a package FOO to be created at initialization time if one does not already exist. The single colon specifies that FRED should be made an external symbol in the package.

In addition, mymodule defines some constants:

<modex.c>+= [<-D->]
static FIXCONSTDEF myfixconsts[] = {
  { "FOO::FROG", 7 },
  { NULL, 0 }
};

static FLOCONSTDEF myfloconsts[] = {
  { "FOO::FROG-F", 5.0 },
  { NULL, 0 }
};

static STRCONSTDEF mystrconsts[] = {
  { "FOO::FROG-S", "Hello" },
  { NULL, 0 }
};

static ULONGCONSTDEF myulongconsts[] = {
  { "FOO::ULONG-MAX", ULONG_MAX },
  { NULL, 0 }
};
Defines myfixconsts, myfloconsts, mystrconsts, myulongconsts (links are to index).

To complete our example, we specify the module table and the simple initializtion routine:

<modex.c>+= [<-D]
static xlshlib_modinfo_t myinfo = {
  XLSHLIB_VERSION_INFO(0,1,0,1),
  myfuns,
  myfixconsts,
  myfloconsts,
  mystrconsts,
  myulongconsts
};

xlshlib_modinfo_t *mymodule__init() { return &myinfo; }
Defines myinfo, mymodule__init (links are to index).

This specifies current and oldest version fields of 0.1 for the module.

Initializing a Module

We already have all the functions we need to get the address of a module's initialization structure. To use the structure, we need a function that processes it to carry out the initialization or to collect information. The initialization function is shlib-init (xshlibinit). First some preliminaries:

<xlshlib.c body>+= (<-U) [<-D->]
<version definitions>
<module table definitions>
<defsysversion variable definition>
<check_version function>

The initialization function is

<xlshlib.c body>+= (<-U) [<-D->]
/* SHLIB-INIT funtab &optional (version -1) (oldest version) */
LVAL xshlibinit()
{
  LVAL subr, val, sym;
  xlshlib_modinfo_t *info = getnpaddr(xlganatptr());
  FUNDEF *p = info->funs;
  FIXCONSTDEF *pfix = info->fixconsts;
  FLOCONSTDEF *pflo = info->floconsts;
  STRCONSTDEF *pstr = info->strconsts;
  struct version_info defversion;

  defversion.current = moreargs()?getfixnum(xlgafixnum()):-1;
  defversion.oldest = moreargs()?getfixnum(xlgafixnum()):defversion.current;
  xllastarg();

  if (! check_version(&defsysversion, &(info->sysversion)))
    xlfail("shared library not compatible with current system");
  if (defversion.current >= 0 &&
      ! check_version(&defversion, &(info->modversion)))
    xlfail("module not compatible with requested version");

  xlsave1(val);
  val = NIL;
  if (p != NULL)
    for (val = NIL; (p->fd_subr) != (LVAL(*)(void)) NULL; p++) {
      subr = cvsubr(p->fd_subr, p->fd_type & TYPEFIELD, 0);
      setmulvalp(subr, (p->fd_type & (TYPEFIELD + 1)) ? TRUE : FALSE);
      val = cons(subr, val);
      if (p->fd_name != NULL) {
        sym = xlenter(p->fd_name);
        setfunction(sym, subr);
      }
    }
  if (pfix != NULL)
    for (; pfix->name != NULL; pfix++) {
      sym = xlenter(pfix->name);
      defconstant(sym, cvfixnum(pfix->val));
    }
  if (pflo != NULL)
    for (; pflo->name != NULL; pflo++) {
      sym = xlenter(pflo->name);
      defconstant(sym, cvflonum(pflo->val));
    }
  if (pstr != NULL)
    for (; pstr->name != NULL; pstr++) {
      sym = xlenter(pstr->name);
      defconstant(sym, cvstring(pstr->val));
    }
  if (info->sysversion.current >= MAKEVERSION(0,1)) {
    ULONGCONSTDEF *pulong = info->ulongconsts;
    if (pulong != NULL)
      for (; pulong->name != NULL; pulong++) {
        sym = xlenter(pulong->name);
        defconstant(sym, ulong2lisp(pulong->val));
      }
  }
  xlpop();
  return xlnreverse(val);
}
Defines shlib-init, xshlibinit (links are to index).

<funtab additions>+= [<-D->]
{   "SHARED-LIBRARY::SHLIB-INIT",         S, xshlibinit      },

Running our example using these raw tools produces

> (setf mex (shlib::shlib-open "modex.dll"))
#<Pointer: #7b0317c8>
> (setf ini (shlib::shlib-symaddr mex "mymodule__init"))
#<Pointer: #7afed01a>
> (setf ftab (shlib::call-by-address ini))
#<Pointer: #7afef058>
> (shlib::shlib-init ftab)
(#<Subr: #400be088>)
> (foo:fred 1 2)
3
> foo::frog
7
> foo::frog-f
5.0
> foo::frog-s
"Hello"
> foo::ulong-max
4294967295

A Reflection Function

A variant of the initialization function can be used to obtain information on the content of a library module. shlib-info returns a list of the two version numbers, the function name strings and the constant name strings contained in the module table argument.

<xlshlib.c body>+= (<-U) [<-D]
/* SHLIB-INFO funtab */
LVAL xshlibinfo()
{
  LVAL val;
  xlshlib_modinfo_t *info = getnpaddr(xlganatptr());
  FUNDEF *p = info->funs;
  FIXCONSTDEF *pfix = info->fixconsts;
  FLOCONSTDEF *pflo = info->floconsts;
  STRCONSTDEF *pstr = info->strconsts;
  xllastarg();

  if (! check_version(&defsysversion, &(info->sysversion)))
    xlfail("shared library not compatible with current system");

  xlsave1(val);
  val = cons(cvfixnum((FIXTYPE) info->modversion.current), NIL);
  val = cons(cvfixnum((FIXTYPE) info->modversion.oldest), val);
  val = cons(NIL, val);
  if (p != NULL) {
    for (; (p->fd_subr) != (LVAL(*)(void)) NULL; p++)
      rplaca(val, cons(cvstring(p->fd_name), car(val)));
    rplaca(val, xlnreverse(car(val)));
  }
  val = cons(NIL, val);
  if (pfix != NULL)
    for (; pfix->name != NULL; pfix++)
      rplaca(val, cons(cvstring(pfix->name), car(val)));
  if (pflo != NULL)
    for (; pflo->name != NULL; pflo++)
      rplaca(val, cons(cvstring(pflo->name), car(val)));
  if (pstr != NULL)
    for (; pstr->name != NULL; pstr++)
      rplaca(val, cons(cvstring(pstr->name), car(val)));
  if (info->sysversion.current >= MAKEVERSION(0,1)) {
    ULONGCONSTDEF *pulong = info->ulongconsts;
    for (; pulong->name != NULL; pulong++)
      rplaca(val, cons(cvstring(pulong->name), car(val)));
  }
  rplaca(val, xlnreverse(car(val)));
  xlpop();
  return xlnreverse(val);
}
Defines shlib-info, xshlibinfo (links are to index).

<funtab additions>+= [<-D]
{   "SHARED-LIBRARY::SHLIB-INFO",         S, xshlibinfo      },

A Lisp Front End

We need a front end to make this a bit cleaner. A structure is used to hold the shared library handle and name,

<shared library structure definition>= (U->)
(defstruct (shared-library
            (:constructor (make-shared-library (name path handle subrs)))
            (:print-function print-shlib))
  name path handle subrs)
Defines shared-library (links are to index).

The structure print function is

<shared library structure print function>= (U->)
(defun print-shlib (shlib stream depth)
  (format stream "#<shared library ~s>" (shared-library-name shlib)))
Defines print-shlib (links are to index).

A shared library is loaded with load-shared-library. The default module name is determined as the base file name for the path, but an altenate can be specified.

<load-shared-library definition>= (U->)
(defun load-shared-library (path &optional
                                 (name (pathname-name path))
                                 (version -1)
                                 (oldest version))
  (let ((*package* *package*)
        (handle (shlib-open path))
        (success nil))
    (unwind-protect
        (let* ((init (shlib-symaddr handle (format nil "~a__init" name)))
               (ftab (call-by-address init))
               (subrs (shlib-init ftab version oldest))
               (shlib (make-shared-library name path handle subrs)))
          ;;(register-saver shlib #'close-shared-library)
          (setf success t)
          shlib)
      (unless success (shlib-close handle)))))
Defines load-shared-library (links are to index).

A shared library is closed by close-shared-library.

<close-shared-library definition>= (U->)
(defun close-shared-library (shlib)
  ;;(unregister-saver shlib)
  (dolist (s (shared-library-subrs shlib))
    (clear-subr s))
  (shlib-close (shared-library-handle shlib)))
Defines close-shared-library (links are to index).

The function shared-library-information provides information about the library module's content.

<shared-library-information definition>= (U->)
(defun shared-library-information (path &optional (name (pathname-name path)))
  (let ((*package* *package*)
        (handle (shlib-open path)))
    (unwind-protect
        (let* ((init (shlib-symaddr handle (format nil "~a__init" name)))
               (ftab (call-by-address init)))
          (shlib-info ftab))
      (shlib-close handle))))
Defines shared-library-information (links are to index).

The implementation is in the file shlib.lsp.

<shlib.lsp>=
(defpackage "SHARED-LIBRARY" (:use "XLISP") (:nicknames "SHLIB"))
(in-package "SHARED-LIBRARY")
<shared library structure definition>
<shared library structure print function>

(export '(load-shared-library close-shared-library
          shared-library-information))

<load-shared-library definition>
<close-shared-library definition>
<shared-library-information definition>

The example using this front end:

> (use-package "SHLIB")
T
> (shared-library-information "modex.dll" "mymodule")
(1 1 ("FOO:FRED") ("FOO::FROG" "FOO::FROG-F" "FOO::FROG-S" "FOO::ULONG-MAX"))
> (load-shared-library "modex.dll" "mymodule")
#<shared library "mymodule">
> (foo:fred 1 2)
3
> foo::frog
7
> foo::frog-f
5.0
> foo::frog-s
"Hello"
> foo::ulong-max
4294967295

Open Issues

Indices

Chunks

Identifiers