Interfacing to C Code

Table of Contents

Introduction

To use this code you will need the snapshot of February 3, 1998, or later. This includes support code. You also need the file wrap.lsp, which is available in the Extras/wrappers directory of the source tree. On UNIX systems you should be able to install the wrapper code by running configure and make in the root of the distribution and then configure and make install in the Extras/wrappers subdirectory. On the Macintosh or Win32 you can load wrap.lsp into the executable. Some additional files for the Macintosh and for Win32 are also avilable.

Simple Examples

<csimple.c>=
double fred = 2.0;

int cfrog(int x, int y)
{
  return x + y;
}

and want to provide access to fred and cfrog from Lisp. To do this, create a file simple.wrp containing

<simple.wrp>= [D->]
(wrap:c-lines "extern double fred;"
              "int cfrog (int, int);")
(wrap:c-variable "fred" :flonum (:get get-fred) (:set set-fred))
(wrap:c-function frog "cfrog" (:integer :integer) :integer)

From within XLISP-STAT, first load wrap.lsp and then evaluate

(wrap:make-wrappers "simple.wrp")

Next, create a shared library simple.dll from csimple.c and simple.c. On HP-UX, for example, this would be done with

cc -Aa +z -DX11WINDOWS -g -D_XPG2 -D_HPUX_SOURCE \ 
  -I/usr/include/X11R5 -I../.. -c csimple.c -o csimple.o
ld -b -o simple.dll simple.o csimple.o

Finally, load simple.lsp, or byte compile and load simple.fsl, and we can use the wrappers. get-fred returns the current value of the C variable fred,

> (get-fred)
2.0

> (set-fred 3)
3
> (get-fred)
3.0

> (frog 1 2)
3

C constants can be mapped to Lisp constants by adding appropriate calls to the c-constant macro in the wrapper file simple.wrp.

<simple.wrp>+= [<-D]
(wrap:c-lines "#define A_LONG 7"
              "#define A_FLONUM 3.1415"
              "#define A_STRING \"my string\""
              "#define A_ULONG 0xFFFFFFFF")
(wrap:c-constant a-long "A_LONG" :integer)
(wrap:c-constant a-flonum "A_FLONUM" :flonum)
(wrap:c-constant a-string "A_STRING" :string)
(wrap:c-constant a-ulong "A_ULONG" :unsigned)

These can then be accessed as

> a-long
7
> a-flonum
3.1415
> a-string
"my string"
> a-ulong
4294967295

When accessing system functions we usually need to include a header file. This is done with the c-lines macro. For example, to access the POSIX getlogin and getuid functions we can use

<POSIX wrappers>= (U->) [D->]
(wrap:c-lines "#include <unistd.h>")
(wrap:c-function getuid "getuid" () :integer)
(wrap:c-function getlogin "getlogin" () :string)

Defines getlogin, getuid (links are to index).

<public POSIX symbols>= (U->) [D->]
getuid getlogin

defined in the file posix.wrp. These are used as

> (posix:getuid)
100
> (posix:getlogin)
"luke"

As a final, more elaborate example, suppose we want to access the information returned by getpwnam and getpwuid. These functions return a pointer to a struct passwd, which is defined in pwd.h and must contain the fields [cite lewine91:_posix_progr_guide, p. 554]

Member Name	Member Type
pw_name	char *
pw_uid	uid_t
pw_gid	gid_t
pw_dir	char *
pw_shell	char *

We can provide read access to these elements [I'm not sure how best to deal with other elements on a system-dependent basis; I suppose the #+ mechanism could be used but that seems less than ideal.] of a struct passwd structure referenced by a pointer with

<POSIX wrappers>+= (U->) [<-D->]
(wrap:c-lines "#include <pwd.h>")
(wrap:c-pointer (:struct "passwd")
                (:get pw-name "pw_name" :string)
                (:get pw-uid "pw_uid" :integer)
                (:get pw-gid "pw_gid" :integer)
                (:get pw-dir "pw_dir" :string)
                (:get pw-shell "pw_shell" :string))

Given a pointer p to such a structure, we can then, for example, retrieve the name component with

(pw-name p)

Wrappers for the getpwnam and getpwuid functions that return pointers to the internal struct passwd data are defined as

<POSIX wrappers>+= (U->) [<-D->]
(wrap:c-function base-getpwnam "getpwnam" (:string) (:cptr (:struct "passwd")))
(wrap:c-function base-getpwuid "getpwuid" (:integer) (:cptr (:struct "passwd")))

We can then define user-level functions that return all POSIX-specified elements of the passwd structure as multiple values [This is consistent with the way CL handles the time decomposition functions, for example. An alternative would be to define and return an appropriate Lisp structure or object.] by

<POSIX wrappers>+= (U->) [<-D->]
(defun getpwnam (name)
  (pw-values (base-getpwnam name)))
(defun getpwuid (uid)
  (pw-values (base-getpwuid uid)))

Defines getpwnam, getpwuid (links are to index).

<public POSIX symbols>+= (U->) [<-D->]
getpwnam getpwuid

These functions need locking in a multi-threaded environment. The multiple value returns are constructed by

<POSIX wrappers>+= (U->) [<-D->]
(defun pw-values (pw)
  (when pw
        (values  (pw-name pw)
                 (pw-uid pw)
                 (pw-gid pw)
                 (pw-dir pw)
                 (pw-shell pw))))

Defines pw-values (links are to index).

The (when pw ...) form in this definition allows for the fact that a NULL pointer, the error return for the C functions, is returned as NIL by the wrapper functions.

Some examples:

> (posix:getpwnam "fred")
NIL
> (posix:getpwnam "luke")
"luke"
100
1
"/NOKOMIS/users/luke"
"/usr/local/bin/tcsh"
> (posix:getpwuid 100)
"luke"
100
1
"/NOKOMIS/users/luke"
"/usr/local/bin/tcsh"

Overview of the Wrapper System

The symbols and macros for the wrapper system are exported from the C-WRAPPERS package with nickname WRAP. Wrapper files could define their packages to :use this package, but that isn't necessary since the wrapper code is not needed at runtime, only at wrap time, which is treated as the equivalent of compile time for determining when expressions are evaluated during wrapping. Instead, it is best to reference the symbols with fully qualified names using the wrap: prefix.

The function make-wrappers is responsible for generating wrappers from its file argument. This function also accepts a :name keyword argument for specifying an alternate module name; the default module name is the base name of the file. The module name is used to construct the names of the C and Lisp output files.

The wrapper macros exported from the C-WRAPPERS package are

c-lines

writes its argument strings to the C file.

c-constant

defines a Lisp constant corresponding to a C constant (typically a defined C macro or an enum value).

c-variable

allows reader and writer functions for accessing a C variable to be specified.

c-function

specifies an interface to a C function.

c-subr

registers a C SUBR implementation.

c-pointer

specifies constructors and accessors for pointers to compound data structures.

c-version

specifies version information for the shared library.

Type Information

• A string representing a valid C type name, such as "double" (but not "struct passwd"). The type name must be a standard name or be defined in some included header file.
• A list of the form (:struct name) of (:union name). name must be a string representing a known named struct or union.
• A list of the form (:signed itype) or (:unsigned itype) with itype one of "char", "short", "int", or "long".
• A list of the form (:cptr c-type), (:cptr c-type nil), or (:cptr c-type t) where c-type may be any C-type, including a pointer type. The optional third argument indicates whether NULL is allowed; it defaults to t.

• The symbol :void, used to represent functions with no return value.
• The symbol :integer. This indicates a Lisp fixnum in Lisp and a long in C. All signed integral C values are converted to long at the interface level.
• The symbol :unsigned. This represents a nonnegative Lisp number that is either a fixnum or a bignum small enough to be represented as a C unsigned long. In C this represents an unsigned long, the type used to represent all unsigned integers at the interface level.
• The symbol :flonum representing a Lisp floating point number and a C double.
• The symbol :string. On input from Lisp to C, the address of the Lisp string is passed as a pointer to char. An argument of NIL is interpreted as a null pointer on input. For return values, the C value, if non-null, is assumed to point to a null-terminated string and is converted to a new Lisp string. A null value is returned as a NIL.
• The symbol :lval representing a Lisp object pointer. The corresponding C type is LVAL.
• A C-type of the form (:cptr c-type), (:cptr c-type nil), or (:cptr c-type t). On input these should be typed Lisp C-pointers, which should always represent non-null values, or NIL, representing C NULL. On output they are returned as Lisp C-pointers or NIL, depending on whether the value is non-null or NULL.

The c-lines Macro

(wrap:c-lines "#include <stdlib.h>"
              "#include <stdio.h>"
              "#define _POSIX_SOURCE 1"

The c-constant Macro

(wrap:c-constant symbol string type)

(wrap:c-constant long-max "LONG_MAX" :integer)

The c-variable Macro

(wrap:c-variable name type clause1 clause2 ...)

(:get reader-name)

(:set writer-name)

Section [<-] gives an example of accessing a C variable.

The c-function and c-subr Macros

(wrap:c-function symbol name (type-1 ... type-n) v-type)

The c-subr macro registers a function written as an internal SUBR with the module. The arguments are the Lisp symbol naming the function and the string naming the C implementation. A third optional argument specifies whether the SUBR returns multiple values; the default is a single-value SUBR. Section [->] gives several examples.

The c-pointer Macro

(wrap:c-pointer type clause1 ...)

(:make make-name)
(:cast cast-name)
(:offset offset-name)
(:get reader-name field type)
(:set writer-name field type)

:make clauses define a constructor function make-name that allocates new memory and returns a pointer to it. The memory is from the Lisp heap and is released by the garbage collector when no more references to it exist from Lisp values. The constructor takes an optional size argument representing the number of items of the type to allocate (or the number of bytes if the type is void). The default size is one.

:cast clauses define a casting function that returns a new C pointer to the argument object. The argument can be another C pointer or a native pointer object. The value returned is either the argument, if it is already of the required type, or a new pointer object referencing the same internal data as the argument but with the appropriate type tag.

:offset clauses define a function that returns a new pointer representing the first argument offset by the second argument. For void pointers the offset is interpreted as a byte count; for others it is an element count. Offset functions are rarely needed since accessor functions take an optional offset argument.

:get and :set clauses define readers and writers for the value of a pointer or a field of the data referenced by a pointer. For simple pointers, such as a double * pointer, the field component would be NIL. For a pointer to a structure the field would be a string naming the structure field. The type is the Lisp-type of the return or argument value value. Reader functions require one argument, the pointer to be read. They also accept a second optional argument, an integer representing an offset; the default offset is zero. Writer functions require two arguments, the pointer and a new value. They accept an optional offset as a third argument.

The c-version Macro

(wrap:c-version major minor oldmajor oldminor)

Sections [<-] and [->] contain several examples.

Additional Examples

Basic Pointers

<wrapptrs.wrp>=
<pointer wrappers package and module setup>
<pointer wrapper code>

The functions defined here are placed in the POINTER-WRAPPERS package with nickname WRAPPTRS. The code is placed in the module named "wrapptrs".

<pointer wrappers package and module setup>= (<-U U->)
(provide "wrapptrs")
(defpackage "POINTER-WRAPPERS" (:nicknames "WRAPPTRS") (:use "XLISP"))
(in-package "WRAPPTRS")

(export '(<public pointer wrapper symbols>))

For generic pointers to void we only need a constructor and a caster.

<pointer wrapper code>= (<-U) [D->]
(wrap:c-pointer "void"
                (:make make-c-void)
                (:cast cast-c-void))

Defines cast-c-void, make-c-void (links are to index).

<public pointer wrapper symbols>= (<-U U->) [D->]
make-c-void cast-c-void

Pointers to generic pointers also need an offset and a reader function. An assignment function might make sense as well but I'll omit it for now.

<pointer wrapper code>+= (<-U) [<-D->]
(wrap:c-pointer (:cptr "void")
                (:make make-c-void-p)
                (:cast cast-c-void-p)
                (:offset offset-c-void-p)
                (:get get-c-void-p nil (:cptr "void")))

Defines cast-c-void-p, get-c-void-p, make-c-void-p, offset-c-void-p (links are to index).

<public pointer wrapper symbols>+= (<-U U->) [<-D->]
make-c-void-p cast-c-void-p offset-c-void-p get-c-void-p

For others we need the full range. The char integral types are

<pointer wrapper code>+= (<-U) [<-D->]
(wrap:c-pointer "char"
                (:make make-c-char)
                (:cast cast-c-char)
                (:offset offset-c-char)
                (:get get-c-char nil :integer)
                (:set set-c-char nil :integer))
(wrap:c-pointer (:signed "char")
                (:make make-c-schar)
                (:cast cast-c-schar)
                (:offset offset-c-schar)
                (:get get-c-schar nil :integer)
                (:set set-c-schar nil :integer))
(wrap:c-pointer (:unsigned "char")
                (:make make-c-uchar)
                (:cast cast-c-uchar)
                (:offset offset-c-uchar)
                (:get get-c-uchar nil :integer)
                (:set set-c-uchar nil :integer))

Defines cast-c-char, cast-c-schar, cast-c-uchar, get-c-char, get-c-schar, get-c-uchar, make-c-char, make-c-schar, make-c-uchar, offset-c-char, offset-c-schar, offset-c-uchar, set-c-char, set-c-schar, set-c-uchar (links are to index).

<public pointer wrapper symbols>+= (<-U U->) [<-D->]
make-c-char cast-c-char offset-c-char get-c-char set-c-char
make-c-schar cast-c-schar offset-c-schar get-c-schar set-c-schar
make-c-uchar cast-c-uchar offset-c-uchar get-c-uchar set-c-uchar

The short integral types are

<pointer wrapper code>+= (<-U) [<-D->]
(wrap:c-pointer "short"
                (:make make-c-short)
                (:cast cast-c-short)
                (:offset offset-c-short)
                (:get get-c-short nil :integer)
                (:set set-c-short nil :integer))
(wrap:c-pointer (:unsigned "short")
                (:make make-c-ushort)
                (:cast cast-c-ushort)
                (:offset offset-c-ushort)
                (:get get-c-ushort nil :integer)
                (:set set-c-ushort nil :integer))

Defines cast-c-short, cast-c-ushort, get-c-short, get-c-ushort, make-c-short, make-c-ushort, offset-c-short, offset-c-ushort, set-c-short, set-c-ushort (links are to index).

<public pointer wrapper symbols>+= (<-U U->) [<-D->]
make-c-short cast-c-short offset-c-short get-c-short set-c-short
make-c-ushort cast-c-ushort offset-c-ushort get-c-ushort set-c-ushort

The int types are

<pointer wrapper code>+= (<-U) [<-D->]
(wrap:c-pointer "int"
                (:make make-c-int)
                (:cast cast-c-int)
                (:offset offset-c-int)
                (:get get-c-int nil :integer)
                (:set set-c-int nil :integer))
(wrap:c-pointer (:unsigned "int")
                (:make make-c-uint)
                (:cast cast-c-uint)
                (:offset offset-c-uint)
                (:get get-c-uint nil :integer)
                (:set set-c-uint nil :integer))

Defines cast-c-int, cast-c-uint, get-c-int, get-c-uint, make-c-int, make-c-uint, offset-c-int, offset-c-uint, set-c-int, set-c-uint (links are to index).

<public pointer wrapper symbols>+= (<-U U->) [<-D->]
make-c-int cast-c-int offset-c-int get-c-int set-c-int
make-c-uint cast-c-uint offset-c-uint get-c-uint set-c-uint

The long types are

<pointer wrapper code>+= (<-U) [<-D->]
(wrap:c-pointer "long"
                (:make make-c-long)
                (:cast cast-c-long)
                (:offset offset-c-long)
                (:get get-c-long nil :integer)
                (:set set-c-long nil :integer))
(wrap:c-pointer (:unsigned "long")
                (:make make-c-ulong)
                (:cast cast-c-ulong)
                (:offset offset-c-ulong)
                (:get get-c-ulong nil :integer)
                (:set set-c-ulong nil :integer))

Defines cast-c-long, cast-c-ulong, get-c-long, get-c-ulong, make-c-long, make-c-ulong, offset-c-long, offset-c-ulong, set-c-long, set-c-ulong (links are to index).

<public pointer wrapper symbols>+= (<-U U->) [<-D->]
make-c-long cast-c-long offset-c-long get-c-long set-c-long
make-c-ulong cast-c-ulong offset-c-ulong get-c-ulong set-c-ulong

Floating point pointer wrappers are defined by

<pointer wrapper code>+= (<-U) [<-D->]
(wrap:c-pointer "float"
                (:make make-c-float)
                (:cast cast-c-float)
                (:offset offset-c-float)
                (:get get-c-float nil :flonum)
                (:set set-c-float nil :flonum))
(wrap:c-pointer "double"
                (:make make-c-double)
                (:cast cast-c-double)
                (:offset offset-c-double)
                (:get get-c-double nil :flonum)
                (:set set-c-double nil :flonum))

Defines cast-c-double, cast-c-float, get-c-double, get-c-float, make-c-double, make-c-float, offset-c-double, offset-c-float, set-c-double, set-c-float (links are to index).

<public pointer wrapper symbols>+= (<-U U->) [<-D->]
make-c-float cast-c-float offset-c-float get-c-float set-c-float
make-c-double cast-c-double offset-c-double get-c-double set-c-double

Finally, for pointers to strings we need a caster, offsetter and reader:

<pointer wrapper code>+= (<-U) [<-D]
(wrap:c-pointer (:cptr "char")
                (:cast cast-c-string)
                (:offset offset-c-string)
                (:get get-c-string nil :string))

Defines cast-c-string, get-c-string, make-c-string, offset-c-string, set-c-string (links are to index).

<public pointer wrapper symbols>+= (<-U U->) [<-D]
make-c-string cast-c-string offset-c-string get-c-string set-c-string

Lisp Data

Here is a simple interface to the internal cons function.

<test.wrp>= [D->]
(wrap:c-function my-cons "cons" (:lval :lval) :lval)

Defines my-cons (links are to index).

Instead of using c-function, we can define a SUBR and register it with c-subr.

<test.wrp>+= [<-D->]
(wrap:c-lines "~
static LVAL mycons(void)
{
  LVAL x = xlgetarg();
  LVAL y = xlgetarg();
  xllastarg();
  return cons(x,y);
}")
(wrap:c-subr my-cons-1 "mycons")

Defines my-cons-1, mycons (links are to index).

As an example of a multiple value SUBR, here is a function that returns the car and cdr of a cons cell as multiple values.

<test.wrp>+= [<-D]
(wrap:c-lines "~
static LVAL myuncons(void)
{
  LVAL x = xlgacons();
  xllastarg();
  xlnumresults = 2;
  xlresults[0] = car(x);
  xlresults[1] = cdr(x);
  return car(x);
}")
(wrap:c-subr my-uncons "myuncons" t)

Defines my-uncons, myuncons (links are to index).

Environment and User Information

<POSIX wrappers>+= (U->) [<-D->]
(wrap:c-function base-getenv "getenv" (:string) :string)

The entire environment is available in the global variable environ.

<POSIX wrappers>+= (U->) [<-D->]
(wrap:c-lines "extern char **environ;")
(wrap:c-variable "environ" (:cptr (:cptr "char")) (:get get-environ-cptr))

The public getenv function returns the entire environment if called with no argument and the value of the specified variable if a string argument is supplied:

> (posix:getenv)
("CVSROOT=/NOKOMIS/users/luke/SRC" "EDITOR=/usr/local/bin/emacs" ...)
> (posix:getenv "EDITOR")
"/usr/local/bin/emacs"

<POSIX wrappers>+= (U->) [<-D->]
(defun getenv (&optional name)
  (if name
      (base-getenv name)
    (get-environ (get-environ-cptr) 0 nil)))

Defines getenv (links are to index).

<public POSIX symbols>+= (U->) [<-D]
getenv

with the helper function get-environ defined as

<POSIX wrappers>+= (U->) [<-D]
(defun get-environ (p i val)
  (let ((e (get-c-string p i)))
    (if (null e)
        (nreverse val)
      (get-environ p (+ i 1) (cons e val)))))

Defines get-environ (links are to index).

This uses the get-c-string pointer accessor from Section [<-].

Internet Addresses

<inet.wrp>= [D->]
(eval-when (:compile-toplevel :load-toplevel :execute)
           (require "wrapptrs"))
(defpackage "INTERNET" (:use "XLISP" "WRAPPTRS") (:nicknames "INET"))
(in-package "INET")
(export '(<public internet functions>))
(wrap:c-lines "#include <netinet/in.h>")
(wrap:c-lines "#include <arpa/inet.h>")
(wrap:c-lines "
#define HAVE_INET_ATON 0 /**** configure should do this */
#if ! HAVE_INET_ATON
int inet_aton(const char *strptr, struct in_addr *addrptr)
{
  unsigned long a = inet_addr(strptr); /**** not portable */
  if (a == INADDR_NONE)
    return 0;
  memcpy(addrptr, &a, 4);
  return 1;
}
#endif")

The C function inet_aton is accessed by

<inet.wrp>+= [<-D->]
(wrap:c-function base-inet-aton "inet_aton" (:string (:cptr "void")) :integer)

Defines base-inet-aton (links are to index).

The exported interface returns the address as a typed array. [Since there is no unsigned char typed array yet, I'm using a char array, which may be signed or unsigned. I need to add unsigned typed arrays. Also I need to make array-data-address an exported symbol from SHLIB.]

<inet.wrp>+= [<-D->]
(defun inet-aton (string)
  (let* ((i (make-array 4 :element-type 'c-char))
         (vi (cast-c-void (array-data-address i))))
    (if (= (base-inet-aton string vi) 0)
        nil
      i)))

Defines inet-aton (links are to index).

<public internet functions>= (<-U) [D->]
inet-aton

The inverse C function inet_ntoa is a bit unusual in that it takes a structure argument, not a pointer to a structure. This can't be handled directly by the wrapping mechanism, so an intermediate function needs to be defined.

<inet.wrp>+= [<-D->]
(wrap:c-lines "
static char *my_inet_ntoa(struct in_addr *a)
{
  return inet_ntoa(*a);
}")
(wrap:c-function base-inet-ntoa "my_inet_ntoa" ((:cptr "void")) :string)

Defines base-inet-ntoa (links are to index).

The exported version checks that the address is a character vector of length 4. A version supporting IN6 would switch on the size.

<inet.wrp>+= [<-D->]
(defun inet-ntoa (addr)
  (unless (typep addr '(vector c-char 4))
          (error "~s is not a valid internet address" addr))
  (base-inet-ntoa (cast-c-void (array-data-address addr))))

Defines inet-ntoa (links are to index).

<public internet functions>+= (<-U) [<-D->]
inet-ntoa

Some examples:

> (inet:inet-aton "128.101.50.6")
#(-128 101 50 6)
> (inet:inet-ntoa *)
"128.101.50.6"

If IN6 is to be supported, then a representation that includes the address family should probably be included, though the size of the byte array (4 for IN and 16 for IN6) does currently contain that information).

Host information

<inet.wrp>+= [<-D->]
(wrap:c-lines "#include <netdb.h>"
              "#include <sys/socket.h>")
(wrap:c-constant HOST_NOT_FOUND "HOST_NOT_FOUND" :integer)
(wrap:c-constant TRY_AGAIN "TRY_AGAIN" :integer)
(wrap:c-constant NO_RECOVERY "NO_RECOVERY" :integer)
(wrap:c-constant NO_DATA "NO_DATA" :integer)
(wrap:c-constant AF_INET "AF_INET" :integer)

Defines AF_INET, HOST_NOT_FOUND, NO_DATA, NO_RECOVERY, TRY_AGAIN (links are to index).

Host data is returned in struct hostent structures.

<inet.wrp>+= [<-D->]
(wrap:c-pointer (:struct "hostent")
                (:get hent-name "h_name" :string)
                (:get hent-aliases "h_aliases" (:cptr (:cptr "char")))
                (:get hent-addrtype "h_addrtype" :integer)
                (:get hent-length "h_length" :integer)
                (:get hent-addr-list "h_addr_list" (:cptr (:cptr "void"))))

The internal functions for obtaining host information are

<inet.wrp>+= [<-D->]
(wrap:c-function base-gethostbyname "gethostbyname"
                 (:string) (:cptr (:struct "hostent")))
(wrap:c-function base-gethostbyaddr "gethostbyaddr"
                 ((:cptr "void") :integer :integer) (:cptr (:struct "hostent")))

Defines base-gethostbyaddr, base-gethostbyname (links are to index).

The functions return error information in the global variable h_errno.

<inet.wrp>+= [<-D->]
(wrap:c-lines "extern int h_errno;")
(wrap:c-variable "h_errno" :integer (:get get-h-errno))

Again we return results as multiple values.

<inet.wrp>+= [<-D->]
(defun hent-values (h)
  (if h
      (values (hent-name h)
              (map-cptr-list #'get-c-string (hent-aliases h))
              (hent-addrtype h)
              (hent-length h)
              (flet ((inet-addr (p)
                       (let* ((n (hent-length h))
                              (a (make-array n :element-type 'c-char)))
                         (dotimes (i n a)
                           (setf (elt a i) (get-c-uchar p i))))))
                (mapcar #'inet-addr
                        (map-cptr-list #'get-c-void-p (hent-addr-list h)))))
    (values nil
            (let ((e (get-h-errno)))
              (cond
               ((= e HOST_NOT_FOUND) 'HOST_NOT_FOUND)
               ((= e TRY_AGAIN) 'TRY_AGAIN)
               ((= e NO_RECOVERY) 'NO_RECOVERY)
               ((= e NO_DATA) 'NO_DATA)
               (t e))))))

Defines hent-values (links are to index).

The helper function map-cptr-list converts a NULL-terminated pointer array to a list using the fun argument for reading elements.

<inet.wrp>+= [<-D->]
(defun map-cptr-list (fun ptr)
  (do* ((val nil)
        (count 0 (+ count 1))
        (v (funcall fun ptr count) (funcall fun ptr count)))
       ((null v) (nreverse val))
       (push v val)))

Defines map-cptr-list (links are to index).

The public functions are

<inet.wrp>+= [<-D]
(defun gethostbyname (hostname)
  (hent-values (base-gethostbyname hostname)))

(defun gethostbyaddr (addr)
  (unless (typep addr '(vector c-char 4))
          (error "~s is not a valid internet address" addr))
  (let ((p (cast-c-void (array-data-address addr))))
    (hent-values (base-gethostbyaddr p 4 AF_INET))))

Defines gethostbyaddr, gethostbyname (links are to index).

<public internet functions>+= (<-U) [<-D]
gethostbyname gethostbyaddr

Again locking is needed in a multi-threaded environment, or the thread-safe versions should be used once they are standardized.

Here are some examples:

> (inet:gethostbyname "nokomis")
"nokomis.stat.umn.edu"
NIL
2
4
(#(-128 101 50 6))
> (inet:gethostbyaddr (inet:inet-aton "128.101.50.6"))
"nokomis.stat.umn.edu"
NIL
2
4
(#(-128 101 50 6))

Implementation

The C Type Registry

<type representation>= (U->) [D->]
static LVAL s_types_registry = NULL;

Defines s_types_registry (links are to index).

<initialize s_types_registry if necessary>= (U->)
if (s_types_registry == NULL) {
  s_types_registry = xlenter("SYSTEM::*C-TYPES-REGISTRY*");
  setvalue(s_types_registry, NIL);
}

Types are looked up with xlw_lookup_type. First the list of registered types is searched for a matching one. If that fails, a new entry is created and returned.

<wrapper declarations>= (U->) [D->]
LVAL xlw_lookup_type(char *tname);

Defines xlw_lookup_type (links are to index).

<type representation>+= (U->) [<-D]
LVAL xlw_lookup_type(char *tname)
{
  LVAL next, types;
  <initialize s_types_registry if necessary>
  types = getvalue(s_types_registry);
  for (next = types; consp(next); next = cdr(next))
    if (stringp(car(next)) && strcmp(getstring(car(next)), tname) == 0)
      return car(next);
  types = cons(cvstring(tname), types);
  setvalue(s_types_registry, types);
  return car(types);
}

Defines xlw_lookup_type (links are to index).

A C file that uses a type tag needs to declare the type with DECLARE_CPTR_TYPE. This macro defines a static variable to hold the type tag and initializes the variable to NULL.

<wrapper macros>= (U->) [D->]
#define DECLARE_CPTR_TYPE(t) static LVAL xlw_##t##_type_tag=NULL;

Defines DECLARE_CPTR_TYPE (links are to index).

This defininiton uses the ANSI C ## facility for merging tokens in macro expansion. The tag for a data type is retrieved with CPTR_TYPE.

<wrapper macros>+= (U->) [<-D->]
#define CPTR_TYPE(t) \
  (xlw_##t##_type_tag == NULL ? \
   xlw_##t##_type_tag = xlw_lookup_type(#t) : xlw_##t##_type_tag)

Defines CPTR_TYPE (links are to index).

The # token in the argument to xlw_lookup_type is the ANSI ``stringization'' token. This approach insures that tokens are only looked up once per file and can be compared using ==.

Using these macros, we can declare a generic pointer, a pointer to void.

<declaration of void pointer type>= (U->)
DECLARE_CPTR_TYPE(void)

The type tag would be retrieved by an expression of the form

CPTR_TYPE(void)

C Pointer Representation

<wrapper macros>+= (U->) [<-D->]
#define cptrp(x) (consp(x)&&stringp(car(x))&&natptrp(cdr(x)))
#define getcptype(x) car(x)
#define getcpptr(x) cdr(x)
#define getcpaddr(x) getnpaddr(getcpptr(x))
#define getcpprot(x) getnpprot(getcpptr(x))
#define newcptr(x,y) cons(x,y)

Defines cptrp, getcpptr, getcptype, newcptr (links are to index).

The predicate cptr_type_p checks whether the object is a valid pointer either of the specified type or a generic pointer to void.

<wrapper macros>+= (U->) [<-D]
#define cptr_type_p(p,t) \
  (cptrp(p) && \
   (getcptype(p) == (t) || getcptype(p) == CPTR_TYPE(void)))

Defines cptr_type_p (links are to index).

The function xlgacptr reads a C pointer argument off the stack and returns it or signals an error. An argument of NIL is interpreted as a null pointer; an error is signaled for a null pointer if null_ok is false. An error is signaled if the native pointer of a C pointer contains a NULL address.

<C wrapper support code>= (U->) [D->]
LVAL xlgacptr(LVAL type, int null_ok)
{
  LVAL p = xlgetarg();
  if ((null(p) && null_ok) ||
      (cptr_type_p(p,type) && getcpaddr(p) != NULL))
    return p;
  else
    return xlbadtype(p);
}

Defines xlgacptr (links are to index).

<wrapper declarations>+= (U->) [<-D->]
LVAL xlgacptr(LVAL type, int null_ok);

Defines xlgacptr (links are to index).

An internal pointer is converted to a C pointer by cvcptr. In addition to the pointer, this function takes the type and data item to protect as arguments. If the pointer is NULL, then NIL is returned. The data argument is protected during allocation.

<C wrapper support code>+= (U->) [<-D->]
LVAL cvcptr(LVAL type, void *v, LVAL data)
{
  if (v == NULL)
    return NIL;
  else {
    LVAL ptr, val;
    xlprot1(data);
    xlsave1(ptr);
    ptr = newnatptr(v, data);
    val = newcptr(type,ptr);
    xlpopn(2);
    return val;
  }
}

Defines cvcptr (links are to index).

<wrapper declarations>+= (U->) [<-D->]
LVAL cvcptr(LVAL type, void *v, LVAL data);

Defines cvcptr (links are to index).

Some Generic Functions and Macros

Constructor Functions

<C wrapper support code>+= (U->) [<-D->]
LVAL xlw_make_cptr(LVAL type, size_t elsize)
{
  LVAL data, count;
  FIXTYPE n = 1;
  if (moreargs()) {
    count = xlgafixnum();
    n = getfixnum(count);
    if (n <= 0)
      xlbadtype(count);
  }
  xllastarg();
  data = mktvec(n * elsize, s_c_char);
  return cvcptr(type, gettvecdata(data), data);
}

Defines xlw_make_cptr (links are to index).

<wrapper declarations>+= (U->) [<-D->]
LVAL xlw_make_cptr(LVAL type, size_t elsize);

Defines xlw_make_cptr (links are to index).

Caster Functions

<C wrapper support code>+= (U->) [<-D->]
LVAL xlw_cast_cptr(LVAL type)
{
  LVAL p = xlgetarg();
  xllastarg();
  if (null(p))
    return NIL;
  else if (cptrp(p)) /* won't be a NULL pointer */
    return newcptr(type, getcpptr(p));
  else if (natptrp(p)) /* need to check for NULL */
    return getnpaddr(p) == NULL ? NIL : newcptr(type, p);
  else
    return xlbadtype(p);
}

Defines xlw_cast_cptr (links are to index).

<wrapper declarations>+= (U->) [<-D->]
LVAL xlw_cast_cptr(LVAL type);

Defines xlw_cast_cptr (links are to index).

Offsetters

<C wrapper support code>+= (U->) [<-D]
LVAL xlw_offset_cptr(LVAL type, size_t elsize)
{
  LVAL p = xlgetarg();
  size_t off = getfixnum(xlgafixnum()) * elsize;
  xllastarg();
  if (! cptr_type_p(p, type))
    xlbadtype(p);
  return cvcptr(type, (char *) getcpaddr(p) + off, getcpprot(p));
}

Defines xlw_offset_cptr (links are to index).

<wrapper declarations>+= (U->) [<-D]
LVAL xlw_offset_cptr(LVAL type, size_t elsize);

Defines xlw_offset_cptr (links are to index).

Generating C Code

Top Level

<lisp interface>= (U->) [D->]
(defvar *wrapper-functions*)
(defvar *wrapper-fixnum-constants*)
(defvar *wrapper-unsigned-constants*)
(defvar *wrapper-flonum-constants*)
(defvar *wrapper-string-constants*)
(defvar *wrapper-cptr-types*)
(defvar *wrapper-module-version*)
(defvar *c-output*)

Defines *c-output*, *wrapper-fixnum-constants*, *wrapper-flonum-constants*, *wrapper-functions*, *wrapper-module-version*, *wrapper-string-constants*, *wrapper-unsigned-constants* (links are to index).

One of these is the output stream for the C file, *c-output*. Writing to this stream is handled by the function

<lisp interface>+= (U->) [<-D->]
(defun write-c-line (fmt &rest args)
  (format *c-output* "~&~?~%" fmt args)
  nil)

The wrapper generating function make-wrapper itself is defined as

<lisp interface>+= (U->) [<-D->]
(defun make-wrappers (file &key (name (pathname-name file)))
  (unless (equal (pathname-type file) "wrp")
          (error "file ~a does not have a .wrp extension" file))
  (let ((c-file (merge-pathnames (make-pathname :name name :type "c") file))
        (lisp-file (merge-pathnames (make-pathname :name name :type "lsp") file))
        (*package* *package*)
        (*readtable* *readtable*)
        (*wrapper-functions* nil)
        (*wrapper-fixnum-constants* nil)
        (*wrapper-unsigned-constants* nil)
        (*wrapper-flonum-constants* nil)
        (*wrapper-string-constants* nil)
        (*wrapper-cptr-types* nil)
        (*wrapper-module-version* nil)
        (eof (cons nil nil)))
    <process the wrapper file>))

Defines make-wrappers (links are to index).

The wrapper file is processed by

<process the wrapper file>= (<-U)
(with-open-file (in file)
  (with-open-file (*c-output* c-file :direction :output)
    (with-open-file (lisp-out lisp-file :direction :output)
      <write header to *c-output*>
      <write header to lisp-out>
      (loop
       (let ((expr (read in nil eof)))
         (when (eq expr eof) (return))
         (let ((wexpr (wrap-expression expr)))
           (when wexpr
                 (let ((*print-readably* t)
                       (system:*print-symbol-package* t))
                   (format lisp-out "~&~s~%" wexpr))))))
      <write trailer to lisp-out>
      <write trailer to *c-output*>)))

The header for the C file contains a comment labeling the file as automatically generated and brings in two include files.

<write header to *c-output*>= (<-U)
(write-c-line "/* Generated automatically from ~a by make-wrappers. */" file)
(write-c-line "#include \"xlshlib.h\"")
(write-c-line "#include \"xlwrap.h\"")

The header for the Lisp file again contains a comment.

<write header to lisp-out>= (<-U)
(format lisp-out ";; Generated automatically from ~a by make-wrappers.~%" file)

The trailer for the Lisp file loads the DLL. [This needs to be modified if static loading is to be supported.]

<write trailer to lisp-out>= (<-U)
(let ((path (format nil "(merge-pathnames \"~a.dll\" *load-truename*)" name))
      (vers (if *wrapper-module-version*
                (let* ((major (first *wrapper-module-version*))
                       (minor (second *wrapper-module-version*))
                       (oldmajor (third *wrapper-module-version*))
                       (oldminor (fourth *wrapper-module-version*))
                       (vers (+ (* (^ 2 16) major) minor))
                       (oldvers (+ (* (^ 2 16) oldmajor) oldminor)))
                  (format nil "~d ~d" vers oldvers))
              nil)))
  (format lisp-out "(shlib::load-shared-library ~a ~s ~@[ ~a~])~%" path name vers))

The merge-pathname call is used to merge the library file name with the directory provided in the load call for Lisp file, the directory part of *load-truename*. This assumes that the Lisp and library files are in the same directory. [*load-truename* is used instead of *load-pathname* in case the load path has no directory component. This can create problems with shared library systems that use a search path that doesn't contain the current directory.]

The trailer for the C file defines the function and constant tables and the initialization routine for the module.

<write trailer to *c-output*>= (<-U)
(let ((system:*print-symbol-package* t))
  <write functions table>
  <write fixnum constants table>
  <write flonum constants table>
  <write string constants table>
  <write unsigned constants table>
  <write module table>
  <write module initialization routine>

The function table is written by

<write functions table>= (<-U)
(write-c-line "static FUNDEF ~a_funs[] = {" name)
(dolist (e (reverse *wrapper-functions*))
  (let ((sym (first e))
        (fun (second e))
        (mvals (third e)))
    (unless (symbol-package sym) (error "~s has no package" sym))
    (write-c-line "  { \"~s\", ~:[SUBR~;MVSUBR~], ~a }," sym mvals fun)))
(write-c-line "  { NULL, 0, NULL}~%};")

The fixnum constants are written out by

<write fixnum constants table>= (<-U)
(write-c-line "static FIXCONSTDEF ~a_fixconsts[] = {" name)
(dolist (e (reverse *wrapper-fixnum-constants*))
  (let ((sym (car e))
        (val (cdr e)))
    (unless (symbol-package sym) (error "~s has no package" sym))
    (write-c-line "  { \"~s\", ~a }," sym val)))
(write-c-line "  { NULL, 0}~%};")

the flonum constants by

<write flonum constants table>= (<-U)
(write-c-line "static FLOCONSTDEF ~a_floconsts[] = {" name)
(dolist (e (reverse *wrapper-flonum-constants*))
  (let ((sym (car e))
        (val (cdr e)))
    (unless (symbol-package sym) (error "~s has no package" sym))
    (write-c-line "  { \"~s\", ~a }," sym val)))
(write-c-line "  { NULL, 0.0}~%};")

the string constants by

<write string constants table>= (<-U)
(write-c-line "static STRCONSTDEF ~a_strconsts[] = {" name)
(dolist (e (reverse *wrapper-string-constants*))
  (let ((sym (car e))
        (val (cdr e)))
    (unless (symbol-package sym) (error "~s has no package" sym))
    (write-c-line "  { \"~s\", ~a }," sym val)))
(write-c-line "  { NULL, NULL}~%};")

and the unsigned constants by

<write unsigned constants table>= (<-U)
(write-c-line "static ULONGCONSTDEF ~a_ulongconsts[] = {" name)
(dolist (e (reverse *wrapper-unsigned-constants*))
  (let ((sym (car e))
        (val (cdr e)))
    (unless (symbol-package sym) (error "~s has no package" sym))
    (write-c-line "  { \"~s\", ~a }," sym val)))
(write-c-line "  { NULL, 0}~%};")

The module table combines the function and constant tables.

<write module table>= (<-U)
(let ((vers (if *wrapper-module-version* *wrapper-module-version* '(0 1 0 1))))
  (write-c-line "static xlshlib_modinfo_t ~a_info = {~%~
                ~2tXLSHLIB_VERSION_INFO(~{~d,~d,~d,~d~}),~%~
                ~2t~a_funs,~%~
                ~2t~a_fixconsts,~%~
                ~2t~a_floconsts,~%~
                ~2t~a_strconsts,~%~
                ~2t~a_ulongconsts~%};"
                name vers name name name name name))

The initialization routine returns the module table's address.

<write module initialization routine>= (<-U)
(write-c-line "xlshlib_modinfo_t *~a__init(void) { return &~a_info; }"
              name name))

Wrapping Expressions

<lisp interface>+= (U->) [<-D->]
(defun wrap-expression (expr)
  (case (first expr)
        (macrolet (error "top level MACROLET not supported in wrappers"))
        (eval-when
         (let ((sits (second expr)))
           (when (or (member 'compile sits) (member :compile-toplevel sits))
                 (dolist (e (rest (rest expr)))
                   (eval e))))
         expr)
        ((defun defstruct do do* dolist dotimes) expr)
        (progn `(progn ,@(mapcar #'wrap-expression (rest expr))))
        ((in-package defpackage defmacro) (eval expr) expr)
        (t (multiple-value-bind (ee again) (macroexpand expr)
             (if again
                 (wrap-expression ee)
               ee)))))

Defines wrap-expression (links are to index).

This definition does not include any error catching. [Error catching along the lines used by compile-file could be added.]

Type Specifiers

<lisp interface>+= (U->) [<-D->]
(defun c-type (type)
  (case type
        (:void "void")
        (:integer "long")
        (:unsigned "unsigned long")
        (:flonum "double")
        (:string "char *")
        (:lval "LVAL")
        (t (cond
            ((stringp type) type)
            ((signed-type-p type) (format nil "signed ~a" (second type)))
            ((unsigned-type-p type) (format nil "unsigned ~a" (second type)))
            ((pointer-type-p type) (format nil "~a *" (c-type (second type))))
            ((struct-type-p type) (format nil "struct ~a" (second type)))
            ((union-type-p type) (format nil "union ~a" (second type)))
            (t (error "type ~s is unknown" type))))))

Defines c-type (links are to index).

mangled-type creates a single word name for describing the type. It isn't guaranteed to be a one-to one mapping, but will be for reasonable naming schemes.

<lisp interface>+= (U->) [<-D->]
(defun mangled-type (type)
  (case type
        (:void "void")
        (:integer "long")
        (:unsigned "unsigned_long")
        (:flonum "double")
        (:string "c_string")
        (:lval "LVAL")
        (t (cond
            ((stringp type) type)
            ((signed-type-p type) (format nil "signed_~a" (second type)))
            ((unsigned-type-p type) (format nil "unsigned_~a" (second type)))
            ((pointer-type-p type) (format nil "~a_P" (mangled-type (second type))))
            ((struct-type-p type) (format nil "S_~a" (second type)))
            ((union-type-p type) (format nil "U_~a" (second type)))
            (t (error "type ~s is unknown" type))))))

Defines mangled-type (links are to index).

Here are some predicates for recognizing compound type specifiers.

<lisp interface>+= (U->) [<-D->]
(defun pointer-type-p (type)
  (and (consp type) (eq (first type) :cptr)))
(defun signed-type-p (type)
  (and (consp type) (eq (first type) :signed)))
(defun unsigned-type-p (type)
  (and (consp type) (eq (first type) :unsigned)))
(defun struct-type-p (type)
  (and (consp type) (eq (first type) :struct)))
(defun union-type-p (type)
  (and (consp type) (eq (first type) :union)))

Defines pointer-type-p, signed-type-p, struct-type-p, union-type-p, unsigned-type-p (links are to index).

The register-pointer-type function is used to insure that a pointer tag is defined before use and is define only once.

<lisp interface>+= (U->) [<-D->]
(defun register-pointer-type (type)
  (unless *wrapper-cptr-types*
          (push "void" *wrapper-cptr-types*)
          (write-c-line "DECLARE_CPTR_TYPE(~a)" "void"))
  (unless (member type *wrapper-cptr-types* :test #'equal)
          (push type *wrapper-cptr-types*)
          (write-c-line "DECLARE_CPTR_TYPE(~a)" (mangled-type type))))

C Lines

<lisp interface>+= (U->) [<-D->]
(defmacro c-lines (&rest lines)
  (dolist (ln lines)
    (write-c-line ln)))

Defines c-lines (links are to index).

Constants

<lisp interface>+= (U->) [<-D->]
(defmacro c-constant (name cname type)
  (case type
        (:integer (push (cons name cname) *wrapper-fixnum-constants*))
        (:unsigned (push (cons name cname) *wrapper-unsigned-constants*))
        (:flonum (push (cons name cname) *wrapper-flonum-constants*))
        (:string (push (cons name cname) *wrapper-string-constants*))
        (t (error "can't handle constants of type ~s" type)))
  nil)

Defines c-constant (links are to index).

Variables

<lisp interface>+= (U->) [<-D->]
(defmacro c-variable (name type &rest clauses)
  (when (pointer-type-p type)
        (register-pointer-type (second type)))
  (dolist (c clauses)
    (case (first c)
          (:get (write-c-variable-get name type (second c)))
          (:set (write-c-variable-set name type (second c))))))

Defines c-variable (links are to index).

Reader functions are written using the format

<lisp interface>+= (U->) [<-D->]
(defconstant c-variable-get-fmt "~
static LVAL ~a(void) {
  xllastarg();
  return ~@?;
}")

Defines c-variable-get-fmt (links are to index).

The format is filled in by

<lisp interface>+= (U->) [<-D->]
(defun write-c-variable-get (name type fun)
  (let ((cfun (c-function-name "get_~a_var" name)))
    (write-c-line c-variable-get-fmt cfun (c-value-fmt type) name nil)
    (register-subr fun cfun)))

Defines write-c-variable-get (links are to index).

C function names are generated by c-function-name. [This should probably be modified to use an index to insure uniqueness.]

<lisp interface>+= (U->) [<-D->]
(defun c-function-name (fmt &rest args)
  (format nil "xlw_~?" fmt args))

Lisp functions are registered with register-subr for later entry in the module function table.

<lisp interface>+= (U->) [<-D->]
(defun register-subr (lisp-name c-name &optional mvals)
  (push (list lisp-name c-name mvals) *wrapper-functions*)
  nil)

The function c-value-fmt produces the format string for the value.

<lisp interface>+= (U->) [<-D->]
(defun c-value-fmt (type)
  (case type
        (:void "NIL")
        (:integer "long2lisp(~a)")
        (:unsigned "ulong2lisp(~a)")
        (:flonum "cvflonum(~a)")
        (:string "cvstrornil(~a)")
        (:lval "~a")
        (t (if (pointer-type-p type)
               (format nil "cvcptr(CPTR_TYPE(~a),~~a,~~a)"
                       (mangled-type (second type)))
             (error "can't handle ~a value type" type)))))

Defines c-value-fmt (links are to index).

For string data, this uses the support function cvstrornil to return NIL for a null pointer and a string converted with cvstring for a non-null pointer.

Variable modifiers are written with the format [This does not yet allow for modifying pointer-valued variables.]

<lisp interface>+= (U->) [<-D->]
(defconstant c-variable-set-fmt "~
static LVAL ~a(void) {
  LVAL xlw__val = xlgetarg();
  xllastarg();
  ~a = ~@?;
  return xlw__val;
}")

Defines c-variable-set-fmt (links are to index).

This format is filled in by the function

<lisp interface>+= (U->) [<-D->]
(defun write-c-variable-set (name type fun)
  (let ((cfun (c-function-name "set_~a_var" name))
        (afmt (c-argument-fmt type)))
    (write-c-line c-variable-set-fmt cfun name afmt "xlw__val")
    (register-subr fun cfun)))

Defines write-c-variable-set (links are to index).

The argument format is generated by c-argument-fmt.

<lisp interface>+= (U->) [<-D->]
(defun c-argument-fmt (type)
  (case type
        (:integer "lisp2long(~a)")
        (:unsigned "lisp2ulong(~a)")
        (:flonum "makefloat(~a)")
        (:string "getstring(~a)")
        (:lval "~a")
        (t (error "can't handle ~a argument type" type))))

Defines c-argument-fmt (links are to index).

Functions

<lisp interface>+= (U->) [<-D->]
(defconstant c-function-fmt "~
static LVAL ~a(void)
{
~:{~&  ~a ~a = ~a;~}
~@[~&  ~a xlw__v;~]~&  xllastarg();
  ~@[~*xlw__v = ~]~a(~:[~2*~;~a~{,~a~}~]);
  return ~@?;
}")

Defines c-function-fmt (links are to index).

The c-function wrapper fills in this template.

<lisp interface>+= (U->) [<-D->]
(defmacro c-function (name cname args value)
  (dolist (a args)
    (when (pointer-type-p a)
          (register-pointer-type (second a))))
  (when (pointer-type-p value)
        (register-pointer-type (second value)))
  (let* ((fun (c-function-name "_~a_wrap" cname))
         (ainfo (c-function-arginfo args))
         (anames (mapcar #'second ainfo))
         (vt (if (eq value :void) nil (c-type value))))
    (write-c-line c-function-fmt
                  fun
                  ainfo
                  vt
                  vt cname anames (first anames) (rest anames)
                  (c-value-fmt value) "xlw__v" "NIL")
     (register-subr name fun)))

Defines c-function (links are to index).

The function c-function-arginfo computes the argument information needed. For each argument it returns a list of the C type, the generated variable name, and the form for reading the variable from the stack.

<lisp interface>+= (U->) [<-D->]
(defun c-function-arginfo (args)
  (let ((val nil)
        (count 0))
    (dolist (a args (nreverse val))
      (incf count)
      (let ((ct (c-type a))
            (v (format nil "xlw__x~d" count))
            (arg (if (pointer-type-p a)
                     (format nil "getcpaddr(xlgacptr(CPTR_TYPE(~a),~a))"
                             (mangled-type (second a))
                             (if (third a) "TRUE" "FALSE"))
                   (format nil (c-argument-fmt a) "xlgetarg()"))))
        (push (list ct v arg) val)))))

Defines c-function-arginfo (links are to index).

The macro c-subr can be used to register a C SUBR with the module.

<lisp interface>+= (U->) [<-D->]
(defmacro c-subr (fun cfun &optional mvals)
  (register-subr fun cfun mvals))

Defines c-subr (links are to index).

Pointers and Compound Data Structures

<lisp interface>+= (U->) [<-D->]
(defmacro c-pointer (type &rest clauses)
  (register-pointer-type type)
  (dolist (c clauses)
    (case (first c)
          (:make (write-c-pointer-make type (second c)))
          (:cast (write-c-pointer-cast type (second c)))
          (:offset (write-c-pointer-offset type (second c)))
          (:get (write-c-pointer-get type (second c) (third c) (fourth c)))
          (:set (write-c-pointer-set type (second c) (third c) (fourth c))))))

The :make, :cast, and :offset clauses all take one argument, the name of the function to define. The C template for a constructor function is

<lisp interface>+= (U->) [<-D->]
(defconstant c-pointer-make-fmt "~
static LVAL ~a(void)
{
  return xlw_make_cptr(CPTR_TYPE(~a), sizeof(~a));
}")

Defines c-pointer-make-fmt (links are to index).

This template is filed in by

<lisp interface>+= (U->) [<-D->]
(defun write-c-pointer-make (type fun)
  (let* ((mt (mangled-type type))
         (ct (c-type type))
         (cfun (c-function-name "make_~a_cptr" mt)))
    (if (equal type "void")
        (write-c-line c-pointer-make-fmt cfun "void" "char")
      (write-c-line c-pointer-make-fmt cfun mt ct))
    (register-subr fun cfun)))

Defines write-c-pointer-make (links are to index).

The caster template is

<lisp interface>+= (U->) [<-D->]
(defconstant c-pointer-cast-fmt "~
static LVAL ~a()
{
  return xlw_cast_cptr(CPTR_TYPE(~a));
}")

Defines c-pointer-cast-fmt (links are to index).

and is filled in by

<lisp interface>+= (U->) [<-D->]
(defun write-c-pointer-cast (type fun)
  (let* ((mt (mangled-type type))
         (cfun (c-function-name "cast_~a_cptr" mt)))
    (write-c-line c-pointer-cast-fmt cfun mt)
    (register-subr fun cfun)))

Defines write-c-pointer-cast (links are to index).

The offsetter template is

<lisp interface>+= (U->) [<-D->]
(defconstant c-pointer-offset-fmt "~
static LVAL ~a(void)
{
  return xlw_offset_cptr(CPTR_TYPE(~a), sizeof(~a));
}")

Defines c-pointer-offset-fmt (links are to index).

This template is filled in by

<lisp interface>+= (U->) [<-D->]
(defun write-c-pointer-offset (type fun)
  (let* ((mt (mangled-type type))
         (ct (c-type type))
         (cfun (c-function-name "offset_~a_cptr" mt)))
    (if (equal type "void")
        (write-c-line c-pointer-offset-fmt cfun "void" "char")
      (write-c-line c-pointer-offset-fmt cfun mt ct))
    (register-subr fun cfun)))

Defines write-c-pointer-offset (links are to index).

The :get clause generates reader functions for dereferencing a pointer or reading a field. The C function format is

<lisp interface>+= (U->) [<-D->]
(defconstant c-pointer-get-fmt "~
static LVAL ~a(void)
{
  LVAL p = xlgacptr(CPTR_TYPE(~a), FALSE);
  ~a *x = getcpaddr(p);
  FIXTYPE off = moreargs() ? getfixnum(xlgafixnum()) : 0;
  xllastarg();
  return ~@?;
}")

Defines c-pointer-get-fmt (links are to index).

The function write-c-pointer-get fills in this template.

<lisp interface>+= (U->) [<-D->]
(defun write-c-pointer-get (type fun field vtype)
  (when (pointer-type-p vtype)
        (register-pointer-type (second vtype)))
  (let* ((ct (c-type type))
         (mt (mangled-type type))
         (cfun (c-function-name "get_~a~@[_~a~]" mt field))
         (val (format nil "x[off]~@[.~a~]" field))
         (cvt (c-value-fmt vtype)))
    (write-c-line c-pointer-get-fmt cfun mt ct cvt val "p")
    (register-subr fun cfun)))

Defines write-c-pointer-get (links are to index).

The :set clause generates writer functions for assigning new values to a pointer's reference or a field. The C function format is

<lisp interface>+= (U->) [<-D->]
(defconstant c-pointer-set-fmt "~
static LVAL ~a(void)
{
  ~a *x = getcpaddr(xlgacptr(CPTR_TYPE(~a), FALSE));
  LVAL val = xlgetarg();
  FIXTYPE off = moreargs() ? getfixnum(xlgafixnum()) : 0;
  xllastarg();
  x[off]~@[.~a~] = ~@?;
  return val;
}")

Defines c-pointer-set-fmt (links are to index).

The format is filled and written to the C stream by the function

<lisp interface>+= (U->) [<-D->]
(defun write-c-pointer-set (type fun field vtype)
  (when (pointer-type-p vtype)
        (register-pointer-type (second vtype)))
  (let* ((mt (mangled-type type))
         (ct (c-type type))
         (cfun (c-function-name "set_~a~@[_~a~]" mt field))
         (cvt (c-argument-fmt vtype)))
    (write-c-line c-pointer-set-fmt cfun ct mt field cvt "val")
    (register-subr fun cfun)))

Defines write-c-pointer-set (links are to index).

This function does not currently allow the assignment of pointer types. [It isn't clear whether such an assignment should assign the pointer or copy the contents of the pointer. Some way of specifying this would be needed.]

Version Information

<lisp interface>+= (U->) [<-D->]
(defmacro c-version (&optional (major 0) (minor 0) 
                               (oldmajor major) (oldminor minor))
  (setf *wrapper-module-version* (list major minor oldmajor oldminor))
  nil)

Defines c-version (links are to index).

Callbacks

Need special versions for Mac (UPP stuff, pascal conventions) and Windows (stdcall for 95//NT, procedure pointer thunking for 3.1?)

Need SUBR to initialize variable?

Use special variable symbol for callback. Store Lisp function in value cell (so can rebind in let) and store pointer to C function in function cell.

<lisp interface>+= (U->) [<-D]
(defconstant c-callback-fmt "~
static ~a ~a(~a x1, ~a x2)
{
  LVAL xlw_x1, xlw_x2, xlw_v;
  static LVAL fsym = NULL;
  if (fsym == NULL)
    fsym = xlenter(\"~a\");
  xlstkcheck(2);
  xlsave(2);
  xlw_x1 = ~@?;
  xlw_x1 = ~@?;
  xlw_v = xlappn(xlgetfunction(fsym), 2, xlw_x1, xlw_x2);
  xlpopn(2);
  return ...;
}")

Defines c-callback-fmt (links are to index).

Files

<posix.wrp>=
(provide "posix")

(eval-when (:compile-toplevel :load-toplevel :execute)
           (require "wrapptrs"))
(defpackage "POSIX" (:use "XLISP" "WRAPPTRS"))
(in-package "POSIX")

(export '(<public POSIX symbols>))

<POSIX wrappers>

*

<xlwrap.h>=
<wrapper declarations>
<wrapper macros>

*

<xlwrap.c>=
#include "xlisp.h"
#ifdef SHAREDLIBS
#include "xlwrap.h"
<type representation>
<declaration of void pointer type>
<C wrapper support code>
#endif /* SHAREDLIBS */

*

<wrapper package and module setup>= (U-> U->)
(provide "wrappers")
(defpackage "C-WRAPPERS" (:nicknames "WRAP") (:use "XLISP"))
(in-package "C-WRAPPERS")
(export '(<public wrapper symbols>))

*

<public wrapper symbols>= (U-> U->)
make-wrappers
c-lines c-constant c-variable c-function c-subr c-pointer c-version

*

<wrap.lsp>=
<wrapper package and module setup>
<lisp interface>

*

<_autoidx.lsp>=
<wrapper package and module setup>
(system:define-autoload-module "wrap"
  (function <public wrapper symbols>))

<pointer wrappers package and module setup>
(system:define-autoload-module "wrapptrs"
  (function <public pointer wrapper symbols>))

Open Issues

• **** Make sure null pointer are always NIL, cptr's always non-null.
• **** callbacks. need stdcall, pascal versions for win/mac
• **** Fortran, C++ interface?
• **** automatic Makefile/project/exports creation?
• **** use temp files in make-wrappers? Check C file, if exists, for header to avoid overwriting.
• **** use special index variable to make generated variables unique? Simplify c-function-arginfo with mapcar?
• **** extract common part of constant C code generation into function?

References

[1] David M. Beazley. Swig users manual. http://www.cs.utah.edu/ beazley/SWIG/, 1997.

[2] Donald Lewine. POSIX Programmer's Guide. O'Reilly &Associates, 1991.

[3] W. Richard Stevens. UNIX Network Programming, volume I. Prentice-Hall, Upper Saddle River, NJ, 1998.

Indices

Chunks

• <_autoidx.lsp>: D1
• <C wrapper support code>: D1, D2, D3, D4, D5, U6
• <csimple.c>: D1
• <declaration of void pointer type>: D1, U2
• <inet.wrp>: D1, D2, D3, D4, D5, D6, D7, D8, D9, D10, D11, D12
• <initialize s_types_registry if necessary>: D1, U2
• <lisp interface>: D1, D2, D3, D4, D5, D6, D7, D8, D9, D10, D11, D12, D13, D14, D15, D16, D17, D18, D19, D20, D21, D22, D23, D24, D25, D26, D27, D28, D29, D30, D31, D32, D33, D34, D35, D36, U37
• <pointer wrapper code>: U1, D2, D3, D4, D5, D6, D7, D8, D9
• <pointer wrappers package and module setup>: U1, D2, U3
• <POSIX wrappers>: D1, D2, D3, D4, D5, D6, D7, D8, D9, U10
• <posix.wrp>: D1
• <process the wrapper file>: U1, D2
• <public internet functions>: U1, D2, D3, D4
• <public pointer wrapper symbols>: U1, D2, D3, D4, D5, D6, D7, D8, D9, U10
• <public POSIX symbols>: D1, D2, D3, U4
• <public wrapper symbols>: U1, D2, U3
• <simple.wrp>: D1, D2
• <test.wrp>: D1, D2, D3
• <type representation>: D1, D2, U3
• <wrap.lsp>: D1
• <wrapper declarations>: D1, D2, D3, D4, D5, D6, U7
• <wrapper macros>: D1, D2, D3, D4, U5
• <wrapper package and module setup>: D1, U2, U3
• <wrapptrs.wrp>: D1
• <write fixnum constants table>: U1, D2
• <write flonum constants table>: U1, D2
• <write functions table>: U1, D2
• <write header to *c-output*>: U1, D2
• <write header to lisp-out>: U1, D2
• <write module initialization routine>: U1, D2
• <write module table>: U1, D2
• <write string constants table>: U1, D2
• <write trailer to *c-output*>: U1, D2
• <write trailer to lisp-out>: U1, D2
• <write unsigned constants table>: U1, D2
• <xlwrap.c>: D1
• <xlwrap.h>: D1

Identifiers

• AF_INET: D1, U2
• base-gethostbyaddr: D1, U2
• base-gethostbyname: D1, U2
• base-inet-aton: D1, U2
• base-inet-ntoa: D1, U2
• c-argument-fmt: U1, D2, U3, U4
• cast-c-char: D1, U2
• cast-c-double: D1, U2
• cast-c-float: D1, U2
• cast-c-int: D1, U2
• cast-c-long: D1, U2
• cast-c-schar: D1, U2
• cast-c-short: D1, U2
• cast-c-string: D1, U2
• cast-c-uchar: D1, U2
• cast-c-uint: D1, U2
• cast-c-ulong: D1, U2
• cast-c-ushort: D1, U2
• cast-c-void: D1, U2, U3, U4, U5, U6, U7
• cast-c-void-p: D1, U2
• c-callback-fmt: D1
• c-constant: U1, U2, D3, U4
• c-function: U1, U2, U3, U4, U5, U6, U7, U8, U9, U10, U11, U12, D13, U14, U15, U16, U17, U18, U19, U20
• c-function-arginfo: U1, D2
• c-function-fmt: D1, U2
• c-lines: U1, U2, U3, U4, U5, U6, U7, U8, U9, U10, U11, D12, U13
• *c-output*: D1, U2, U3
• c-pointer-cast-fmt: D1, U2
• c-pointer-get-fmt: D1, U2
• c-pointer-make-fmt: D1, U2
• c-pointer-offset-fmt: D1, U2
• c-pointer-set-fmt: D1, U2
• cptrp: D1, U2, U3
• CPTR_TYPE: D1, U2, U3, U4, U5, U6, U7, U8, U9
• cptr_type_p: D1, U2, U3
• c-subr: U1, U2, D3, U4
• c-type: D1, U2, U3, U4, U5, U6, U7
• c-value-fmt: U1, D2, U3, U4
• c-variable: U1, U2, U3, D4, U5, U6, U7, U8, U9
• c-variable-get-fmt: D1, U2
• c-variable-set-fmt: D1, U2
• cvcptr: D1, D2, U3, U4, U5
• c-version: D1, U2
• DECLARE_CPTR_TYPE: D1, U2, U3
• get-c-char: D1, U2
• get-c-double: D1, U2
• get-c-float: D1, U2
• get-c-int: D1, U2
• get-c-long: D1, U2
• getcpptr: D1, U2
• getcptype: D1, U2
• get-c-schar: D1, U2
• get-c-short: D1, U2
• get-c-string: D1, U2, U3
• get-c-uchar: D1, U2, U3
• get-c-uint: D1, U2
• get-c-ulong: D1, U2
• get-c-ushort: D1, U2
• get-c-void-p: D1, U2
• getenv: U1, D2, U3
• get-environ: U1, U2, D3
• gethostbyaddr: U1, D2, U3
• gethostbyname: U1, D2, U3
• getlogin: D1, U2
• getpwnam: U1, D2, U3
• getpwuid: U1, D2, U3
• getuid: D1, U2
• hent-values: D1, U2
• HOST_NOT_FOUND: D1, U2
• inet-aton: U1, D2, U3
• inet-ntoa: U1, D2, U3
• make-c-char: D1, U2
• make-c-double: D1, U2
• make-c-float: D1, U2
• make-c-int: D1, U2
• make-c-long: D1, U2
• make-c-schar: D1, U2
• make-c-short: D1, U2
• make-c-string: D1, U2
• make-c-uchar: D1, U2
• make-c-uint: D1, U2
• make-c-ulong: D1, U2
• make-c-ushort: D1, U2
• make-c-void: D1, U2, U3, U4
• make-c-void-p: D1, U2
• make-wrappers: D1, U2, U3, U4
• mangled-type: D1, U2, U3, U4, U5, U6, U7, U8, U9
• map-cptr-list: U1, D2
• my-cons: D1, U2
• my-cons-1: D1
• mycons: D1
• my-uncons: D1
• myuncons: D1
• newcptr: D1, U2, U3
• NO_DATA: D1, U2
• NO_RECOVERY: D1, U2
• offset-c-char: D1, U2
• offset-c-double: D1, U2
• offset-c-float: D1, U2
• offset-c-int: D1, U2
• offset-c-long: D1, U2
• offset-c-schar: D1, U2
• offset-c-short: D1, U2
• offset-c-string: D1, U2
• offset-c-uchar: D1, U2
• offset-c-uint: D1, U2
• offset-c-ulong: D1, U2
• offset-c-ushort: D1, U2
• offset-c-void-p: D1, U2
• pointer-type-p: U1, U2, D3, U4, U5, U6, U7, U8, U9
• pw-values: U1, D2
• set-c-char: D1, U2
• set-c-double: D1, U2
• set-c-float: D1, U2
• set-c-int: D1, U2
• set-c-long: D1, U2
• set-c-schar: D1, U2
• set-c-short: D1, U2
• set-c-string: D1, U2
• set-c-uchar: D1, U2
• set-c-uint: D1, U2
• set-c-ulong: D1, U2
• set-c-ushort: D1, U2
• signed-type-p: U1, U2, D3
• struct-type-p: U1, U2, D3
• s_types_registry: D1, U2, U3
• TRY_AGAIN: D1, U2
• union-type-p: U1, U2, D3
• unsigned-type-p: U1, U2, D3
• wrap-expression: U1, D2
• *wrapper-fixnum-constants*: D1, U2, U3, U4
• *wrapper-flonum-constants*: D1, U2, U3, U4
• *wrapper-functions*: D1, U2, U3, U4
• *wrapper-module-version*: D1, U2, U3, U4, U5
• *wrapper-string-constants*: D1, U2, U3, U4
• *wrapper-unsigned-constants*: D1, U2, U3, U4
• write-c-pointer-cast: U1, D2
• write-c-pointer-get: U1, D2
• write-c-pointer-make: U1, D2
• write-c-pointer-offset: U1, D2
• write-c-pointer-set: U1, D2
• write-c-variable-get: U1, D2
• write-c-variable-set: U1, D2
• xlgacptr: D1, D2, U3, U4, U5
• xlw_cast_cptr: D1, D2, U3
• xlw_lookup_type: D1, D2, U3
• xlw_make_cptr: D1, D2, U3
• xlw_offset_cptr: D1, D2, U3