+;;;; C callbacks
+
+(defmacro define-callback (name return-type args &body body)
+ (let ((define-callback
+ #+cmu'alien:def-callback
+ #+(and sbcl alien-callbacks)'sb-alien::define-alien-callback
+ #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function))
+ (multiple-value-bind (doc declaration body)
+ (cond
+ ((and (stringp (first body)) (eq (cadr body) 'declare))
+ (values (first body) (second body) (cddr body)))
+ ((stringp (first body))
+ (values (first body) nil (rest body)))
+ ((eq (caar body) 'declare)
+ (values nil (first body) (rest body)))
+ (t (values nil nil body)))
+ `(,define-callback ,name
+ #+(and sbcl alien-callbacks),(alien-type return-type)
+ (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type)
+ ,@(mapcar #'(lambda (arg)
+ (destructuring-bind (name type) arg
+ `(,name ,(alien-type type))))
+ args))
+ ,@(when doc (list doc))
+ ,(to-alien-form
+ `(let (,@(loop
+ for (name type) in args
+ as from-alien-form = (callback-from-alien-form name type)
+ collect `(,name ,from-alien-form)))
+ ,@(when declaration (list declaration))
+ (unwind-protect
+ (progn ,@body)
+ ,@(loop
+ for (name type) in args
+ do (callback-cleanup-form name type))))
+
+ return-type)))))
+
+(defun callback-address (callback)
+ #+cmu(alien::callback-trampoline callback)
+ #+(and sbcl (not alien-callbacks))(sb-alien:alien-function-sap callback)
+ #+(and sbcl alien-callbacks)(sb-alien:alien-sap callback))