| 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.
