Documentation: Callbacks from Tcl to CMUCL
This page describes how to use the CMUCL FFI to allow callbacks from
foreign code into Lisp. This implementation only works when using the
generational garbage collector (you should have :gencgc in your *features* list; this is the case on all x86
platforms). It is also possible to make it work with the
non-generational garbage collector; ask the cmucl-help mailing list.
There is some glue code in Lisp to save into cl-tcl.lisp, some C glue
code to save into tcl-callback.c, and some demo code at the end.
The following code should be saved into a file
cl-tcl.lisp:
;;; Evaluate (alien:load-foreign "/usr/lib/libtcl8.0.so") and
;;; (alien:load-foreign "tcl-demo.o") before compiling or loading
;;; this file. You will also likely need a version of CMUCL where
;;; the /usr/bin/lisp binary has been produced with the flags
;;; -Xlinker --export-dynamic added to OS_LINK_FLAGS in Config.linux*
;;; Note that the Debian binaries usually don't include these flags.
(cl:defpackage "CL-TCL"
(:use "CL" "ALIEN" "C-CALL" "SYSTEM")
(:export
"+TCL-OK+" "+TCL-ERROR+" "+TCL-RETURN+" "+TCL-BREAK+" "+TCL-CONTINUE+"
"TCL-INTERPRETER"
"CREATE-TCL-INTERPRETER" "DESTROY-TCL-INTERPRETER"
"REGISTER-TCL-COMMAND" "UNREGISTER-TCL-COMMAND"
"WITH-TCL-INTERPRETER" "EVAL-TCL-EXPR"))
(in-package :CL-TCL)
;;;; User and Implementation-level constants
(defconstant +TCL-OK+ 0
"TCL return code: Command completed normally; the interpreter's
result contains the command's result.")
(defconstant +TCL-ERROR+ 1
"TCL return code: The command couldn't be completed successfully;
the interpreter's result describes what went wrong.")
(defconstant +TCL-RETURN+ 2
"TCL return code: The command requests that the current procedure
return; the interpreter's result contains the procedure's return value.")
(defconstant +TCL-BREAK+ 3
"TCL return code: The command requests that the innermost loop
be exited; the interpreter's result is meaningless.")
(defconstant +TCL-CONTINUE+ 4
"TCL return code: Go on to the next iteration of the current loop;
the interpreter's result is meaningless.")
;;;; FFI bindings to the Tcl Library and the C-side of the callback stuff
(declaim (inline tcl-createinterp))
(def-alien-routine "Tcl_CreateInterp" system-area-pointer)
(declaim (inline tcl-eval))
(def-alien-routine "Tcl_Eval" int
(interp system-area-pointer :in)
(string c-string :in))
(declaim (inline tcl-getstringresult))
(def-alien-routine "Tcl_GetStringResult" c-string
(interp system-area-pointer :in))
(declaim (inline tcl-deleteinterp))
(def-alien-routine "Tcl_DeleteInterp" void
(interp system-area-pointer :in))
(declaim (inline set-lisp-callback-handler))
(def-alien-routine "Set_Lisp_Callback_Handler" void
(handler unsigned-long :in))
(declaim (inline register-tcl-lisp-command))
(def-alien-routine "Register_Tcl_Lisp_Command" void
(interp system-area-pointer :in)
(name c-string :in))
(declaim (inline unregister-tcl-lisp-command))
(def-alien-routine "Unregister_Tcl_Lisp_Command" void
(interp system-area-pointer :in)
(name c-string :in))
;;;; User-level stuff
(defstruct (tcl-interpreter (:print-function print-tcl-interpreter))
(valid-p t)
(sap (int-sap 0) :type system-area-pointer)
(commands (make-hash-table :test #'equal) :read-only t))
(defun print-tcl-interpreter (inter stream depth)
(declare (ignore depth))
(print-unreadable-object (inter stream :type t :identity t)
(format stream "~:[(INVALID)~;(valid@~8,'0X)~]"
(tcl-interpreter-valid-p inter)
(sap-int (tcl-interpreter-sap inter)))))
(defvar *tcl-interpreter-list* nil
"List of valid TCL interpreters.")
(defun create-tcl-interpreter ()
"Create a TCL interpreter object that can be passed to the other
functions of CL-TCL."
(let ((result (make-tcl-interpreter :sap (tcl-createinterp))))
(push result *tcl-interpreter-list*)
result))
(defun destroy-tcl-interpreter (inter)
"Destroy the TCL interpreter object `inter'."
(assert (and (tcl-interpreter-valid-p inter)
(member inter *tcl-interpreter-list*)))
(setf *tcl-interpreter-list*
(delete (tcl-interpreter-sap inter) *tcl-interpreter-list*
:key #'tcl-interpreter-sap :test #'sap=))
(tcl-deleteinterp (tcl-interpreter-sap inter))
(setf (tcl-interpreter-valid-p inter) nil
(tcl-interpreter-sap inter) (int-sap 0))
inter)
(defun register-tcl-command (inter name handler)
"Registers the lisp function `handler' as the handler for the
command named by the string `name' in the TCL-Interpreter `inter'.
Any previously existing handlers will be superseded. When the
corresponding command is invoked in the TCL interpreter, the handler
will be called with the TCL-Interpreter object, the command name and
all the arguments to the TCL command. The handler must return two
values: The return code (one of +TCL-OK+, +TCL-ERROR+, +TCL-RETURN+,
+TCL-BREAK+ or +TCL-CONTINUE+) and the result or error indicator
string."
(assert (tcl-interpreter-valid-p inter))
(setf (gethash name (tcl-interpreter-commands inter)) handler)
(register-tcl-lisp-command (tcl-interpreter-sap inter) name))
(defun unregister-tcl-command (inter name)
"Unregisters the previously registered command named `name' in the
TCL-Interpreter `inter'. Returns the old handler function."
(assert (tcl-interpreter-valid-p inter))
(let ((handler (gethash name (tcl-interpreter-commands inter) nil)))
(assert handler)
(remhash name (tcl-interpreter-commands inter))
(unregister-tcl-lisp-command (tcl-interpreter-sap inter) name)
handler))
(defmacro with-tcl-interpreter (inter (&rest commands) &body body)
"Evaluate the body in an environment were `inter' is bound to a
Tcl interpreter instance and for each (name tcl-proc) in `commands'
a Tcl command for name is defined, which invokes tcl-proc."
`(let ((,inter (create-tcl-interpreter)))
(unwind-protect
(progn
,@(loop for (name handler) in commands
collect
`(register-tcl-command ,inter ,name ,handler))
,@body)
(destroy-tcl-interpreter ,inter))))
(defun eval-tcl-expr (inter expr)
"Evaluate the expression (string) `expr' in the Tcl-Interpreter
`inter' and return as multiple values the return code and result
string."
(assert (tcl-interpreter-valid-p inter))
(let* ((result-code (tcl-eval (tcl-interpreter-sap inter) expr))
(result-string (tcl-getstringresult (tcl-interpreter-sap inter))))
(values result-code result-string)))
;;;; Lisp-side of the callback stuff.
(defun %lisp-callback-handler (inter-sap args)
(handler-case
(let ((inter (find inter-sap *tcl-interpreter-list*
:key #'tcl-interpreter-sap :test #'sap=)))
(assert (and inter (tcl-interpreter-valid-p inter)))
(let ((handler (gethash (car args)
(tcl-interpreter-commands inter) nil)))
(assert handler)
(multiple-value-bind (code result)
(apply handler inter args)
(cons code result))))
(error (c) (cons +TCL-ERROR+ (format nil "Lisp error: ~A" c)))))
(defun %update-lisp-callback-handler ()
(set-lisp-callback-handler
(kernel:get-lisp-obj-address #'%lisp-callback-handler)))
(defvar *lisp-callback-scavhook*
(ext:make-scavenger-hook :value #'%lisp-callback-handler
:function #'%update-lisp-callback-handler))
(%update-lisp-callback-handler)
The following C code should be saved into a file
tcl-callback.c.
#include <stdlib.h>
#include <string.h>
#include <tcl.h>
#include "lisp.h"
#include "internals.h"
#include "alloc.h"
#include "arch.h"
lispobj lisp_callback_handler;
static lispobj alloc_str_list(char *list[])
{
lispobj result, newcons;
struct cons *ptr;
if (*list == NULL)
result = NIL;
else {
result = newcons = alloc_cons(alloc_string(*list++), NIL);
while (*list != NULL) {
ptr = (struct cons *)PTR(newcons);
newcons = alloc_cons(alloc_string(*list++), NIL);
ptr->cdr = newcons;
}
}
return result;
}
int LispTclProc(ClientData data,Tcl_Interp *interp,int argc,char** argv)
{
lispobj lisp_result;
struct vector *vec;
char* result;
int returnvalue;
lisp_result=funcall2(lisp_callback_handler,alloc_sap(interp),
alloc_str_list(argv));
returnvalue=fixnum_value(CONS(lisp_result)->car);
vec=(struct vector*)PTR(CONS(lisp_result)->cdr);
result=ckalloc((vec->length)+1);
strcpy(result,(char*)vec->data);
interp->result=result;
interp->freeProc=TCL_DYNAMIC;
return returnvalue;
}
void Set_Lisp_Callback_Handler(lispobj handler)
{
lisp_callback_handler=handler;
}
void Register_Tcl_Lisp_Command(Tcl_Interp* interp,char* name)
{
Tcl_CreateCommand(interp,name,LispTclProc,NULL,NULL);
}
void Unregister_Tcl_Lisp_Command(Tcl_Interp* interp,char* name)
{
Tcl_DeleteCommand(interp,name);
}
Here is some code you can use to load the demo into CMUCL:
(alien:load-foreign "/usr/lib/libtcl8.0.so")
(alien:load-foreign (make-pathname :name "tcl-callback" :type "o" :version nil
:defaults *load-truename*))
(load (compile-file (make-pathname :name "cl-tcl" :type "cl" :version nil
:defaults *load-truename*)))
And finally, here is some sample code demonstrating the use of a tcl function which calls back into Lisp:
(cl:defpackage "CL-TCL-DEMO"
(:use "CL" "CL-TCL")
(:export "TCL-DEMO"))
(in-package :CL-TCL-DEMO)
(defun tcl-incr (inter cmd first &optional second)
(declare (ignore inter cmd))
(values 0
(format nil "~D"
(+ (parse-integer first)
(if second (parse-integer second) 1)))))
(defun tcl-demo (n)
(with-tcl-interpreter inter (("lincr" #'tcl-incr))
(multiple-value-bind (code result)
(eval-tcl-expr inter
(format nil "set result \"(\"
for {set i 1} {$i <= ~D} {set i [lincr $i 2]} {append result $i \" \"}
append result \")\"
return $result" n))
(case code
((#.+TCL-OK+ #.+TCL-RETURN+) (read-from-string result))
(t (values code result))))))
This description is adapted from the article
<87k8jzthta.fsf@orion.dent.isdn.cs.tu-berlin.de>
posted to the USENET group comp.lang.lisp on 2000-02-21 by Pierre
Mai.