X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=019991d6e1cf5e79537b880986d5f8fb203f472f;hb=568214ddf4c8ecc881caec98e20848d017974ec0;hp=c93516556097b7746b0863f84fd17c07a3983367;hpb=b5703d98da9ebfd688c87e14862ab4e26dc94d14;p=sbcl.git diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index c935165..019991d 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -45,7 +45,7 @@ (error "badly formed alien name")) (values (cadr name) (car name)))))) -(defmacro def-alien-variable (name type &environment env) +(defmacro define-alien-variable (name type &environment env) #!+sb-doc "Define NAME as an external alien variable of type TYPE. NAME should be a list of a string holding the alien name and a symbol to use as the Lisp @@ -57,31 +57,36 @@ `(eval-when (:compile-toplevel :load-toplevel :execute) ,@(when *new-auxiliary-types* `((%def-auxiliary-alien-types ',*new-auxiliary-types*))) - (%def-alien-variable ',lisp-name - ',alien-name - ',alien-type)))))) + (%define-alien-variable ',lisp-name + ',alien-name + ',alien-type)))))) -;;; Do the actual work of DEF-ALIEN-VARIABLE. +(defmacro def-alien-variable (&rest rest) + (deprecation-warning 'def-alien-variable 'define-alien-variable) + `(define-alien-variable ,@rest)) + +;;; Do the actual work of DEFINE-ALIEN-VARIABLE. (eval-when (:compile-toplevel :load-toplevel :execute) - (defun %def-alien-variable (lisp-name alien-name type) + (defun %define-alien-variable (lisp-name alien-name type) (setf (info :variable :kind lisp-name) :alien) (setf (info :variable :where-from lisp-name) :defined) (clear-info :variable :constant-value lisp-name) (setf (info :variable :alien-info lisp-name) (make-heap-alien-info :type type - :sap-form `(foreign-symbol-address - ',alien-name))))) + :sap-form `(foreign-symbol-address ',alien-name t))))) (defmacro extern-alien (name type &environment env) #!+sb-doc "Access the alien variable named NAME, assuming it is of type TYPE. This is SETFable." - (let ((alien-name (etypecase name - (symbol (guess-alien-name-from-lisp-name name)) - (string name)))) + (let* ((alien-name (etypecase name + (symbol (guess-alien-name-from-lisp-name name)) + (string name))) + (alien-type (parse-alien-type type env)) + (datap (not (alien-fun-type-p alien-type)))) `(%heap-alien ',(make-heap-alien-info - :type (parse-alien-type type env) - :sap-form `(foreign-symbol-address ',alien-name))))) + :type alien-type + :sap-form `(foreign-symbol-address ',alien-name ,datap))))) (defmacro with-alien (bindings &body body &environment env) #!+sb-doc @@ -105,7 +110,8 @@ (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) binding (/show symbol type opt1 opt2) - (let ((alien-type (parse-alien-type type env))) + (let* ((alien-type (parse-alien-type type env)) + (datap (not (alien-fun-type-p alien-type)))) (/show alien-type) (multiple-value-bind (allocation initial-value) (if opt2p @@ -133,16 +139,17 @@ `((setq ,symbol ,initial-value))) ,@body))))) (:extern - (/show ":EXTERN case") + (/show0 ":EXTERN case") (let ((info (make-heap-alien-info :type alien-type :sap-form `(foreign-symbol-address - ',initial-value)))) + ',initial-value + ,datap)))) `((symbol-macrolet ((,symbol (%heap-alien ',info))) ,@body)))) (:local - (/show ":LOCAL case") + (/show0 ":LOCAL case") (let ((var (gensym)) (initval (if initial-value (gensym))) (info (make-local-alien-info :type alien-type))) @@ -160,7 +167,7 @@ (dispose-local-alien ',info ,var)))))))))))) (/show "revised" body) (verify-local-auxiliaries-okay) - (/show "back from VERIFY-LOCAL-AUXILIARIES-OK, returning") + (/show0 "back from VERIFY-LOCAL-AUXILIARIES-OK, returning") `(symbol-macrolet ((&auxiliary-type-definitions& ,(append *new-auxiliary-types* (auxiliary-type-definitions env)))) @@ -174,9 +181,10 @@ (def!method print-object ((value alien-value) stream) (print-unreadable-object (value stream) (format stream - "~S :SAP #X~8,'0X" + "~S ~S #X~8,'0X ~S ~S" 'alien-value - (sap-int (alien-value-sap value))))) + :sap (sap-int (alien-value-sap value)) + :type (unparse-alien-type (alien-value-type value))))) #!-sb-fluid (declaim (inline null-alien)) (defun null-alien (x) @@ -191,7 +199,7 @@ (let ((alien-type (parse-alien-type type env))) (if (eq (compute-alien-rep-type alien-type) 'system-area-pointer) `(%sap-alien ,sap ',alien-type) - (error "cannot make aliens of type ~S out of SAPs" type)))) + (error "cannot make an alien of type ~S out of a SAP" type)))) (defun %sap-alien (sap type) (declare (type system-area-pointer sap) @@ -325,7 +333,7 @@ (let* ((field (slot-or-lose type slot)) (offset (alien-record-field-offset field)) (field-type (alien-record-field-type field))) - (%sap-alien (sap+ (alien-sap alien) (/ offset sb!vm:byte-bits)) + (%sap-alien (sap+ (alien-sap alien) (/ offset sb!vm:n-byte-bits)) (make-alien-pointer-type :to field-type))))))) ;;;; the DEREF operator @@ -341,7 +349,7 @@ (etypecase type (alien-pointer-type (when (cdr indices) - (error "too many indices when derefing ~S: ~D" + (error "too many indices when DEREF'ing ~S: ~W" type (length indices))) (let ((element-type (alien-pointer-type-to type))) @@ -353,7 +361,7 @@ 0)))) (alien-array-type (unless (= (length indices) (length (alien-array-type-dimensions type))) - (error "incorrect number of indices when derefing ~S: ~D" + (error "incorrect number of indices when DEREF'ing ~S: ~W" type (length indices))) (labels ((frob (dims indices offset) (if (null dims) @@ -399,7 +407,7 @@ (type list indices) (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) - (%sap-alien (sap+ (alien-value-sap alien) (/ offset sb!vm:byte-bits)) + (%sap-alien (sap+ (alien-value-sap alien) (/ offset sb!vm:n-byte-bits)) (make-alien-pointer-type :to target-type)))) ;;;; accessing heap alien variables @@ -432,10 +440,10 @@ (alien-sap (alien-sap alien))) (finalize alien - #'(lambda () - (alien-funcall - (extern-alien "free" (function (values) system-area-pointer)) - alien-sap))) + (lambda () + (alien-funcall + (extern-alien "free" (function (values) system-area-pointer)) + alien-sap))) alien)) (defun note-local-alien-type (info alien) @@ -495,11 +503,11 @@ (optimize (inhibit-warnings 3))) (if (or (alien-pointer-type-p target-type) (alien-array-type-p target-type) - (alien-function-type-p target-type)) + (alien-fun-type-p target-type)) (let ((alien-type (alien-value-type alien))) (if (or (alien-pointer-type-p alien-type) (alien-array-type-p alien-type) - (alien-function-type-p alien-type)) + (alien-fun-type-p alien-type)) (naturalize (alien-value-sap alien) target-type) (error "~S cannot be casted." alien))) (error "cannot cast to alien type ~S" (unparse-alien-type target-type)))) @@ -516,8 +524,8 @@ (values (ceiling bits (ecase units (:bits 1) - (:bytes sb!vm:byte-bits) - (:words sb!vm:word-bits)))) + (:bytes sb!vm:n-byte-bits) + (:words sb!vm:n-word-bits)))) (error "unknown size for alien type ~S" (unparse-alien-type alien-type))))) @@ -547,7 +555,7 @@ (funcall (coerce (compute-deposit-lambda type) 'function) sap offset type value)) -;;;; ALIEN-FUNCALL, DEF-ALIEN-ROUTINE +;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE (defun alien-funcall (alien &rest args) #!+sb-doc @@ -558,66 +566,82 @@ (typecase type (alien-pointer-type (apply #'alien-funcall (deref alien) args)) - (alien-function-type - (unless (= (length (alien-function-type-arg-types type)) + (alien-fun-type + (unless (= (length (alien-fun-type-arg-types type)) (length args)) - (error "wrong number of arguments for ~S~%expected ~D, got ~D" + (error "wrong number of arguments for ~S~%expected ~W, got ~W" type - (length (alien-function-type-arg-types type)) + (length (alien-fun-type-arg-types type)) (length args))) - (let ((stub (alien-function-type-stub type))) + (let ((stub (alien-fun-type-stub type))) (unless stub (setf stub (let ((fun (gensym)) (parms (make-gensym-list (length args)))) (compile nil `(lambda (,fun ,@parms) + (declare (optimize (sb!c::insert-step-conditions 0))) (declare (type (alien ,type) ,fun)) (alien-funcall ,fun ,@parms))))) - (setf (alien-function-type-stub type) stub)) + (setf (alien-fun-type-stub type) stub)) (apply stub alien args))) (t (error "~S is not an alien function." alien))))) -(defmacro def-alien-routine (name result-type &rest args &environment env) +(defmacro define-alien-routine (name result-type + &rest args + &environment lexenv) #!+sb-doc - "Def-C-Routine Name Result-Type - {(Arg-Name Arg-Type [Style])}* + "DEFINE-ALIEN-ROUTINE Name Result-Type {(Arg-Name Arg-Type [Style])}* + + Define a foreign interface function for the routine with the specified NAME. + Also automatically DECLAIM the FTYPE of the defined function. - Define a foreign interface function for the routine with the specified Name, - which may be either a string, symbol or list of the form (string symbol). - Return-Type is the Alien type for the function return value. VOID may be - used to specify a function with no result. + NAME may be either a string, a symbol, or a list of the form (string symbol). - The remaining forms specifiy individual arguments that are passed to the - routine. Arg-Name is a symbol that names the argument, primarily for - documentation. Arg-Type is the C-Type of the argument. Style specifies the - say that the argument is passed. + RETURN-TYPE is the alien type for the function return value. VOID may be + used to specify a function with no result. + + The remaining forms specify individual arguments that are passed to the + routine. ARG-NAME is a symbol that names the argument, primarily for + documentation. ARG-TYPE is the C type of the argument. STYLE specifies the + way that the argument is passed. :IN - An :In argument is simply passed by value. The value to be passed is - obtained from argument(s) to the interface function. No values are - returned for :In arguments. This is the default mode. + An :IN argument is simply passed by value. The value to be passed is + obtained from argument(s) to the interface function. No values are + returned for :In arguments. This is the default mode. :OUT - The specified argument type must be a pointer to a fixed sized object. - A pointer to a preallocated object is passed to the routine, and the - the object is accessed on return, with the value being returned from - the interface function. :OUT and :IN-OUT cannot be used with pointers - to arrays, records or functions. + The specified argument type must be a pointer to a fixed sized object. + A pointer to a preallocated object is passed to the routine, and the + the object is accessed on return, with the value being returned from + the interface function. :OUT and :IN-OUT cannot be used with pointers + to arrays, records or functions. :COPY - Similar to :IN, except that the argument values are stored in on - the stack, and a pointer to the object is passed instead of - the values themselves. + This is similar to :IN, except that the argument values are stored + on the stack, and a pointer to the object is passed instead of + the value itself. :IN-OUT - A combination of :OUT and :COPY. A pointer to the argument is passed, - with the object being initialized from the supplied argument and - the return value being determined by accessing the object on return." + This is a combination of :OUT and :COPY. A pointer to the argument is + passed, with the object being initialized from the supplied argument + and the return value being determined by accessing the object on + return." (multiple-value-bind (lisp-name alien-name) (pick-lisp-and-alien-names name) - (collect ((docs) (lisp-args) (arg-types) (alien-vars) + (collect ((docs) (lisp-args) (lisp-arg-types) + (lisp-result-types + (cond ((eql result-type 'void) + ;; What values does a function return, if it + ;; returns no values? Exactly one - NIL. -- APD, + ;; 2003-03-02 + (list 'null)) + (t + ;; FIXME: Check for VALUES. + (list `(alien ,result-type))))) + (arg-types) (alien-vars) (alien-args) (results)) (dolist (arg args) (if (stringp arg) @@ -625,39 +649,71 @@ (destructuring-bind (name type &optional (style :in)) arg (unless (member style '(:in :copy :out :in-out)) (error "bogus argument style ~S in ~S" style arg)) - (unless (eq style :out) - (lisp-args name)) (when (and (member style '(:out :in-out)) - (typep (parse-alien-type type env) + (typep (parse-alien-type type lexenv) 'alien-pointer-type)) (error "can't use :OUT or :IN-OUT on pointer-like type:~% ~S" type)) - (cond ((eq style :in) - (arg-types type) - (alien-args name)) - (t - (arg-types `(* ,type)) - (if (eq style :out) - (alien-vars `(,name ,type)) - (alien-vars `(,name ,type ,name))) - (alien-args `(addr ,name)))) + (let (arg-type) + (cond ((eq style :in) + (setq arg-type type) + (alien-args name)) + (t + (setq arg-type `(* ,type)) + (if (eq style :out) + (alien-vars `(,name ,type)) + (alien-vars `(,name ,type ,name))) + (alien-args `(addr ,name)))) + (arg-types arg-type) + (unless (eq style :out) + (lisp-args name) + (lisp-arg-types t + ;; FIXME: It should be something + ;; like `(ALIEN ,ARG-TYPE), except + ;; for we also accept SAPs where + ;; pointers are required. + ))) (when (or (eq style :out) (eq style :in-out)) - (results name))))) - `(defun ,lisp-name ,(lisp-args) - ,@(docs) - (with-alien - ((,lisp-name (function ,result-type ,@(arg-types)) - :extern ,alien-name) - ,@(alien-vars)) - ,(if (alien-values-type-p result-type) - (let ((temps (make-gensym-list - (length - (alien-values-type-values result-type))))) - `(multiple-value-bind ,temps - (alien-funcall ,lisp-name ,@(alien-args)) - (values ,@temps ,@(results)))) - `(values (alien-funcall ,lisp-name ,@(alien-args)) - ,@(results)))))))) + (results name) + (lisp-result-types `(alien ,type)))))) + `(progn + ;; The theory behind this automatic DECLAIM is that (1) if + ;; you're calling C, static typing is what you're doing + ;; anyway, and (2) such a declamation can be (especially for + ;; alien values) both messy to do by hand and very important + ;; for performance of later code which uses the return value. + (declaim (ftype (function ,(lisp-arg-types) + (values ,@(lisp-result-types) &optional)) + ,lisp-name)) + (defun ,lisp-name ,(lisp-args) + ,@(docs) + (with-alien + ((,lisp-name (function ,result-type ,@(arg-types)) + :extern ,alien-name) + ,@(alien-vars)) + #-nil + (values (alien-funcall ,lisp-name ,@(alien-args)) + ,@(results)) + #+nil + (if (alien-values-type-p result-type) + ;; FIXME: RESULT-TYPE is a type specifier, so it + ;; cannot be of type ALIEN-VALUES-TYPE. Also note, + ;; that if RESULT-TYPE is VOID, then this code + ;; disagrees with the computation of the return type + ;; and with all usages of this macro. -- APD, + ;; 2002-03-02 + (let ((temps (make-gensym-list + (length + (alien-values-type-values result-type))))) + `(multiple-value-bind ,temps + (alien-funcall ,lisp-name ,@(alien-args)) + (values ,@temps ,@(results)))) + (values (alien-funcall ,lisp-name ,@(alien-args)) + ,@(results))))))))) + +(defmacro def-alien-routine (&rest rest) + (deprecation-warning 'def-alien-routine 'define-alien-routine) + `(define-alien-routine ,@rest)) (defun alien-typep (object type) #!+sb-doc @@ -667,3 +723,230 @@ (typep object lisp-rep-type) (and (alien-value-p object) (alien-subtype-p (alien-value-type object) type))))) + +;;;; ALIEN CALLBACKS +;;;; +;;;; See "Foreign Linkage / Callbacks" in the SBCL Internals manual. + +(defvar *alien-callback-info* nil + "Maps SAPs to corresponding CALLBACK-INFO structures: contains all the +information we need to manipulate callbacks after their creation. Used for +changing the lisp-side function they point to, invalidation, etc.") + +(defstruct callback-info + specifier + function ; NULL if invalid + wrapper + index) + +(defun callback-info-key (info) + (cons (callback-info-specifier info) (callback-info-function info))) + +(defun alien-callback-info (alien) + (cdr (assoc (alien-sap alien) *alien-callback-info* :test #'sap=))) + +(defvar *alien-callbacks* (make-hash-table :test #'equal) + "Cache of existing callback SAPs, indexed with (SPECIFER . FUNCTION). Used for +memoization: we don't create new callbacks if one pointing to the correct +function with the same specifier already exists.") + +(defvar *alien-callback-wrappers* (make-hash-table :test #'equal) + "Cache of existing lisp weappers, indexed with SPECIFER. Used for memoization: +we don't create new wrappers if one for the same specifier already exists.") + +(defvar *alien-callback-trampolines* (make-array 32 :fill-pointer 0 :adjustable t) + "Lisp trampoline store: assembler wrappers contain indexes to this, and +ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") + +(defun %alien-callback-sap (specifier result-type argument-types function wrapper) + (let ((key (cons specifier function))) + (or (gethash key *alien-callbacks*) + (setf (gethash key *alien-callbacks*) + (let* ((index (fill-pointer *alien-callback-trampolines*)) + ;; Aside from the INDEX this is known at + ;; compile-time, which could be utilized by + ;; having the two-stage assembler tramp & + ;; wrapper mentioned in [1] above: only the + ;; per-function tramp would need assembler at + ;; runtime. Possibly we could even pregenerate + ;; the code and just patch the index in later. + (assembler-wrapper (alien-callback-assembler-wrapper + index result-type argument-types))) + (vector-push-extend + (alien-callback-lisp-trampoline wrapper function) + *alien-callback-trampolines*) + (let ((sap (vector-sap assembler-wrapper))) + (push (cons sap (make-callback-info :specifier specifier + :function function + :wrapper wrapper + :index index)) + *alien-callback-info*) + sap)))))) + +(defun alien-callback-lisp-trampoline (wrapper function) + (declare (function wrapper) (optimize speed)) + (lambda (args-pointer result-pointer) + (funcall wrapper args-pointer result-pointer function))) + +(defun alien-callback-lisp-wrapper-lambda (specifier result-type argument-types env) + (let* ((arguments (make-gensym-list (length argument-types))) + (argument-names arguments) + (argument-specs (cddr specifier))) + `(lambda (args-pointer result-pointer function) + (let ((args-sap (int-sap + (sb!kernel:get-lisp-obj-address args-pointer))) + (res-sap (int-sap + (sb!kernel:get-lisp-obj-address result-pointer)))) + (with-alien + ,(loop + for spec in argument-specs + for offset = 0 ; FIXME: Should this not be AND OFFSET ...? + then (+ offset (alien-callback-argument-bytes spec env)) + collect `(,(pop argument-names) ,spec + :local ,(alien-callback-accessor-form + spec 'args-sap offset))) + ,(flet ((store (spec) + (if spec + `(setf (deref (sap-alien res-sap (* ,spec))) + (funcall function ,@arguments)) + `(funcall function ,@arguments)))) + (cond ((alien-void-type-p result-type) + (store nil)) + ((alien-integer-type-p result-type) + (if (alien-integer-type-signed result-type) + (store `(signed + ,(alien-type-word-aligned-bits result-type))) + (store + `(unsigned + ,(alien-type-word-aligned-bits result-type))))) + (t + (store (unparse-alien-type result-type))))))) + (values)))) + +(defun invalid-alien-callback (&rest arguments) + (declare (ignore arguments)) + (error "Invalid alien callback called.")) + + +(defun parse-callback-specification (result-type lambda-list) + (values + `(function ,result-type ,@(mapcar #'second lambda-list)) + (mapcar #'first lambda-list))) + + +(defun parse-alien-ftype (specifier env) + (destructuring-bind (function result-type &rest argument-types) + specifier + (aver (eq 'function function)) + (values (parse-alien-type result-type env) + (mapcar (lambda (spec) + (parse-alien-type spec env)) + argument-types)))) + +(defun alien-void-type-p (type) + (and (alien-values-type-p type) (not (alien-values-type-values type)))) + +(defun alien-type-word-aligned-bits (type) + (align-offset (alien-type-bits type) sb!vm:n-word-bits)) + +(defun alien-callback-argument-bytes (spec env) + (let ((type (parse-alien-type spec env))) + (if (or (alien-integer-type-p type) + (alien-float-type-p type) + (alien-pointer-type-p type)) + (ceiling (alien-type-word-aligned-bits type) sb!vm:n-byte-bits) + (error "Unsupported callback argument type: ~A" type)))) + +(defun enter-alien-callback (index return arguments) + (funcall (aref *alien-callback-trampolines* index) + return + arguments)) + +;;;; 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*) + ,(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 calls assembles a new callback for every closure, +;;; which suck 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)))))