+ return
+ arguments))
+
+;;; To ensure that callback wrapper functions continue working even
+;;; if #'ENTER-ALIEN-CALLBACK moves in memory, access to it is indirected
+;;; through the *ENTER-ALIEN-CALLBACK* static symbol. -- JES, 2006-01-01
+(defvar *enter-alien-callback* #'enter-alien-callback)
+
+;;;; interface (not public, yet) for alien callbacks
+
+(defmacro alien-callback (specifier function &environment env)
+ "Returns an alien-value with of alien ftype SPECIFIER, that can be passed to
+an alien function as a pointer to the FUNCTION. If a callback for the given
+SPECIFIER and FUNCTION already exists, it is returned instead of consing a new
+one."
+ ;; Pull out as much work as is convenient to macro-expansion time, specifically
+ ;; everything that can be done given just the SPECIFIER and ENV.
+ (multiple-value-bind (result-type argument-types) (parse-alien-ftype specifier env)
+ `(%sap-alien
+ (%alien-callback-sap ',specifier ',result-type ',argument-types
+ ,function
+ (or (gethash ',specifier *alien-callback-wrappers*)
+ (setf (gethash ',specifier *alien-callback-wrappers*)
+ (compile nil
+ ',(alien-callback-lisp-wrapper-lambda
+ specifier result-type argument-types env)))))
+ ',(parse-alien-type specifier env))))
+
+(defun alien-callback-p (alien)
+ "Returns true if the alien is associated with a lisp-side callback,
+and a secondary return value of true if the callback is still valid."
+ (let ((info (alien-callback-info alien)))
+ (when info
+ (values t (and (callback-info-function info) t)))))
+
+(defun alien-callback-function (alien)
+ "Returns the lisp function designator associated with the callback."
+ (let ((info (alien-callback-info alien)))
+ (when info
+ (callback-info-function info))))
+
+(defun (setf alien-callback-function) (function alien)
+ "Changes the lisp function designated by the callback."
+ (let ((info (alien-callback-info alien)))
+ (unless info
+ (error "Not an alien callback: ~S" alien))
+ ;; sap cache
+ (let ((key (callback-info-key info)))
+ (remhash key *alien-callbacks*)
+ (setf (gethash key *alien-callbacks*) (alien-sap alien)))
+ ;; trampoline
+ (setf (aref *alien-callback-trampolines* (callback-info-index info))
+ (alien-callback-lisp-trampoline (callback-info-wrapper info) function))
+ ;; metadata
+ (setf (callback-info-function info) function)
+ function))
+
+(defun invalidate-alien-callback (alien)
+ "Invalidates the callback designated by the alien, if any, allowing the
+associated lisp function to be GC'd, and causing further calls to the same
+callback signal an error."
+ (let ((info (alien-callback-info alien)))
+ (when (and info (callback-info-function info))
+ ;; sap cache
+ (remhash (callback-info-key info) *alien-callbacks*)
+ ;; trampoline
+ (setf (aref *alien-callback-trampolines* (callback-info-index info))
+ #'invalid-alien-callback)
+ ;; metadata
+ (setf (callback-info-function info) nil)
+ t)))
+
+;;; FIXME: This call assembles a new callback for every closure,
+;;; which sucks hugely. ...not that I can think of an obvious
+;;; solution. Possibly maybe we could write a generalized closure
+;;; callback analogous to closure_tramp, and share the actual wrapper?
+;;;
+;;; For lambdas that result in simple-funs we get the callback from
+;;; the cache on subsequent calls.
+(defmacro alien-lambda (result-type typed-lambda-list &body forms)
+ (multiple-value-bind (specifier lambda-list)
+ (parse-callback-specification result-type typed-lambda-list)
+ `(alien-callback ,specifier (lambda ,lambda-list ,@forms))))
+
+;;; FIXME: Should subsequent (SETF FDEFINITION) affect the callback or not?
+;;; What about subsequent DEFINE-ALIEN-CALLBACKs? My guess is that changing
+;;; the FDEFINITION should invalidate the callback, and redefining the
+;;; callback should change existing callbacks to point to the new defintion.
+(defmacro define-alien-callback (name result-type typed-lambda-list &body forms)
+ "Defines #'NAME as a function with the given body and lambda-list, and NAME as
+the alien callback for that function with the given alien type."
+ (declare (symbol name))
+ (multiple-value-bind (specifier lambda-list)
+ (parse-callback-specification result-type typed-lambda-list)
+ `(progn
+ (defun ,name ,lambda-list ,@forms)
+ (defparameter ,name (alien-callback ,specifier #',name)))))