chiark / gitweb /
Fixed wrong foreign function name
[clg] / glib / gcallback.lisp
CommitLineData
112ac1d3 1;; Common Lisp bindings for GTK+ v2.x
2;; Copyright 2000 Espen S. Johnsen <espen@users.sf.net>
c8c48a4c 3;;
112ac1d3 4;; Permission is hereby granted, free of charge, to any person obtaining
5;; a copy of this software and associated documentation files (the
6;; "Software"), to deal in the Software without restriction, including
7;; without limitation the rights to use, copy, modify, merge, publish,
8;; distribute, sublicense, and/or sell copies of the Software, and to
9;; permit persons to whom the Software is furnished to do so, subject to
10;; the following conditions:
c8c48a4c 11;;
112ac1d3 12;; The above copyright notice and this permission notice shall be
13;; included in all copies or substantial portions of the Software.
c8c48a4c 14;;
112ac1d3 15;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22
34c336c4 23;; $Id: gcallback.lisp,v 1.45 2007-06-25 13:49:05 espen Exp $
c8c48a4c 24
25(in-package "GLIB")
26
27(use-prefix "g")
28
29
457f874e 30;;;; Callback invocation
c8c48a4c 31
6851535e 32(deftype gclosure () 'pointer)
33(register-type 'gclosure '|g_closure_get_type|)
34
e378b861 35(defun register-callback-function (function)
36 (check-type function (or null symbol function))
37 (register-user-data function))
c8c48a4c 38
e7225d0f 39;; Callback marshaller for regular signal handlers
40(define-callback signal-handler-marshal nil
56ccd5b7 41 ((gclosure gclosure) (return-value gvalue) (n-params unsigned-int)
42 (param-values pointer) (invocation-hint pointer)
41932b02 43 (callback-id pointer-data))
266ca870 44 (declare (ignore gclosure invocation-hint))
e7225d0f 45 (callback-trampoline #'invoke-signal-handler callback-id n-params param-values return-value))
c8c48a4c 46
41932b02 47;; Callback marshaller for class handlers
e7225d0f 48(define-callback class-handler-marshal nil
49 ((gclosure gclosure) (return-value gvalue) (n-params unsigned-int)
50 (param-values pointer) (invocation-hint pointer)
41932b02 51 (callback-id pointer-data))
e7225d0f 52 (declare (ignore gclosure invocation-hint))
53 (callback-trampoline #'invoke-callback callback-id n-params param-values return-value))
54
55;; Callback marshaller for emission hooks
56(define-callback emission-hook-marshal nil
56ccd5b7 57 ((invocation-hint pointer) (n-params unsigned-int) (param-values pointer)
41932b02 58 (callback-id pointer-data))
5de2b5f6 59 (declare (ignore invocation-hint))
e7225d0f 60 (callback-trampoline #'invoke-callback callback-id n-params param-values))
e0d2987b 61
e7225d0f 62(defun callback-trampoline (restart-wrapper callback-id n-params param-values
63 &optional (return-value (make-pointer 0)))
c8c48a4c 64 (let* ((return-type (unless (null-pointer-p return-value)
e378b861 65 (gvalue-type return-value)))
34f9e1d4 66 (args (loop
67 for n from 0 below n-params
832df308 68 for offset from 0 by +gvalue-size+
77a843ca 69 collect (gvalue-peek (pointer+ param-values offset)))))
832df308 70 (unwind-protect
e7225d0f 71 (multiple-value-bind (result aborted-p)
72 (apply restart-wrapper callback-id nil args)
73 (when (and return-type (not aborted-p))
832df308 74 (gvalue-set return-value result)))
77a843ca 75 ;; TODO: this should be made more general, by adding a type
e7225d0f 76 ;; method to return invalidating functions.
832df308 77 (loop
78 for arg in args
77a843ca 79 when (typep arg 'struct)
832df308 80 do (invalidate-instance arg)))))
81
e7225d0f 82(defun invoke-signal-handler (callback-id return-type &rest args)
83 (declare (ignore return-type))
84 (let* ((instance (first args))
85 (handler-id (signal-handler-find instance '(:data)
86 0 0 nil nil callback-id)))
87 (signal-handler-block instance handler-id)
88 (unwind-protect
89 (restart-case (apply #'invoke-callback callback-id nil args)
bbb73c8a 90 (disconnect () :report "Disconnect and exit signal handler"
e7225d0f 91 (when (signal-handler-is-connected-p instance handler-id)
92 (signal-handler-disconnect instance handler-id))
93 (values nil t))))
94 (when (signal-handler-is-connected-p instance handler-id)
95 (signal-handler-unblock instance handler-id))))
34f9e1d4 96
8755b1a5 97(defun invoke-callback (callback-id return-type &rest args)
e7225d0f 98 (restart-case (apply (find-user-data callback-id) args)
34f9e1d4 99 (continue nil :report "Return from callback function"
e7225d0f 100 (cond
101 (return-type
102 (format *query-io* "Enter return value of type ~S: " return-type)
103 (force-output *query-io*)
104 (eval (read *query-io*)))
105 (t (values nil t))))
34f9e1d4 106 (re-invoke nil :report "Re-invoke callback function"
e7225d0f 107 (apply #'invoke-callback callback-id return-type args))))
c8c48a4c 108
c8c48a4c 109
e378b861 110;;;; Timeouts and idle functions
111
acd28982 112(defconstant +priority-high+ -100)
113(defconstant +priority-default+ 0)
114(defconstant +priority-high-idle+ 100)
115(defconstant +priority-default-idle+ 200)
116(defconstant +priority-low+ 300)
117
118(defbinding source-remove () boolean
119 (tag unsigned-int))
120
bbb73c8a 121(define-callback source-callback-marshal boolean ((callback-id unsigned-int))
122 (invoke-source-callback callback-id))
123
34c336c4 124(defun invoke-source-callback (callback-id &rest args)
125 (restart-case (apply (find-user-data callback-id) args)
bbb73c8a 126 (remove () :report "Exit and remove source callback"
127 nil)
128 (continue () :report "Return from source callback"
129 t)
130 (re-invoke nil :report "Re-invoke source callback"
34c336c4 131 (apply #'invoke-source-callback callback-id args))))
bbb73c8a 132
e378b861 133
134(defbinding (timeout-add "g_timeout_add_full")
acd28982 135 (interval function &optional (priority +priority-default+)) unsigned-int
e378b861 136 (priority int)
137 (interval unsigned-int)
56ccd5b7 138 (source-callback-marshal callback)
e378b861 139 ((register-callback-function function) unsigned-long)
56ccd5b7 140 (user-data-destroy-callback callback))
e378b861 141
acd28982 142(defun timeout-remove (timeout)
143 (source-remove timeout))
144
e378b861 145(defbinding (idle-add "g_idle_add_full")
acd28982 146 (function &optional (priority +priority-default-idle+)) unsigned-int
e378b861 147 (priority int)
56ccd5b7 148 (source-callback-marshal callback)
e378b861 149 ((register-callback-function function) unsigned-long)
56ccd5b7 150 (user-data-destroy-callback callback))
e378b861 151
acd28982 152(defun idle-remove (idle)
153 (source-remove idle))
e378b861 154
c8c48a4c 155
e0d2987b 156;;;; Signal information querying
c8c48a4c 157
e0d2987b 158(defbinding signal-lookup (name type) unsigned-int
c8c48a4c 159 ((signal-name-to-string name) string)
e0d2987b 160 ((find-type-number type t) type-number))
c8c48a4c 161
e0d2987b 162(defbinding signal-name () (copy-of string)
c8c48a4c 163 (signal-id unsigned-int))
164
e0d2987b 165(defbinding signal-list-ids (type) (vector unsigned-int n-ids)
166 ((find-type-number type t) type-number)
167 (n-ids unsigned-int :out))
168
169(defun signal-list-names (type)
170 (map 'list #'signal-name (signal-list-ids type)))
171
172(defun ensure-signal-id-from-type (signal-id type)
c8c48a4c 173 (etypecase signal-id
e0d2987b 174 (integer (if (signal-name signal-id)
175 signal-id
176 (error "Invalid signal id: ~D" signal-id)))
177 ((or symbol string)
178 (let ((numeric-id (signal-lookup signal-id type)))
179 (if (zerop numeric-id)
180 (error "Invalid signal name for ~S: ~D" type signal-id)
181 numeric-id)))))
182
183(defun ensure-signal-id (signal-id instance)
184 (ensure-signal-id-from-type signal-id (type-of instance)))
c8c48a4c 185
e0d2987b 186(eval-when (:compile-toplevel :load-toplevel :execute)
187 (deftype signal-flags ()
188 '(flags :run-first :run-last :run-cleanup :no-recurse
189 :detailed :action :no-hooks))
190
e7225d0f 191 (define-flags-type signal-match-type
192 :id :detail :closure :func :data :unblocked)
193
e0d2987b 194 (defclass signal-query (struct)
195 ((id :allocation :alien :type unsigned-int)
196 (name :allocation :alien :type (copy-of string))
197 (type :allocation :alien :type type-number)
198 (flags :allocation :alien :type signal-flags)
199 (return-type :allocation :alien :type type-number)
200 (n-params :allocation :alien :type unsigned-int)
201 (param-types :allocation :alien :type pointer))
202 (:metaclass struct-class)))
203
204(defbinding signal-query
205 (signal-id &optional (signal-query (make-instance 'signal-query))) nil
206 (signal-id unsigned-int)
77a843ca 207 (signal-query signal-query :in/return))
e0d2987b 208
209(defun signal-param-types (info)
210 (with-slots (n-params param-types) info
211 (map-c-vector 'list
212 #'(lambda (type-number)
213 (type-from-number type-number))
214 param-types 'type-number n-params)))
215
216
217(defun describe-signal (signal-id &optional type)
218 (let ((info (signal-query (ensure-signal-id-from-type signal-id type))))
219 (with-slots (id name type flags return-type n-params) info
457f874e 220 (format t "The signal with id ~D is named '~A' and may be emitted on instances of type ~S." id name (type-from-number type t))
221 (when flags
222 (format t " It has the followin invocation flags: ~{~S ~}" flags))
223 (format t "~%~%Signal handlers should take ~A and return ~A~%"
e0d2987b 224 (if (zerop n-params)
225 "no arguments"
226 (format nil "arguments with the following types: ~A"
457f874e 227 (signal-param-types info)))
228 (cond
229 ((= return-type (find-type-number "void")) "no values")
230 ((not (type-from-number return-type)) "values of unknown type")
231 ((format nil "values of type ~S" (type-from-number return-type))))))))
e0d2987b 232
233
234;;;; Signal connecting and controlling
235
9944c385 236(defvar *overridden-signals* (make-hash-table :test 'equalp))
237
238(defbinding %signal-override-class-closure () nil
239 (signal-id unsigned-int)
240 (type-number type-number)
241 (callback-closure pointer))
242
243
244(defun signal-override-class-closure (name type function)
245 (let* ((signal-id (ensure-signal-id-from-type name type))
246 (type-number (find-type-number type t))
247 (callback-id (gethash (cons type-number signal-id) *overridden-signals*)))
248 (if callback-id
249 (update-user-data callback-id function)
250 (multiple-value-bind (callback-closure callback-id)
e7225d0f 251 (make-callback-closure function class-handler-marshal)
9944c385 252 (%signal-override-class-closure signal-id type-number callback-closure)
253 (setf
254 (gethash (cons type-number signal-id) *overridden-signals*)
255 callback-id)))))
256
257
258(defbinding %signal-chain-from-overridden () nil
259 (args pointer)
260 (return-value (or null gvalue)))
261
38049b1a 262
263(defun %call-next-handler (n-params types args return-type)
9944c385 264 (let ((params (allocate-memory (* n-params +gvalue-size+))))
265 (loop
38049b1a 266 for arg in args
9944c385 267 for type in types
268 for offset from 0 by +gvalue-size+
77a843ca 269 do (gvalue-init (pointer+ params offset) type arg))
9944c385 270
271 (unwind-protect
272 (if return-type
273 (with-gvalue (return-value return-type)
274 (%signal-chain-from-overridden params return-value))
275 (%signal-chain-from-overridden params nil))
276 (progn
277 (loop
278 repeat n-params
279 for offset from 0 by +gvalue-size+
77a843ca 280 do (gvalue-unset (pointer+ params offset)))
9944c385 281 (deallocate-memory params)))))
282
283
284(defmacro define-signal-handler (name ((object class) &rest args) &body body)
285 (let* ((info (signal-query (ensure-signal-id-from-type name class)))
286 (types (cons class (signal-param-types info)))
287 (n-params (1+ (slot-value info 'n-params)))
288 (return-type (type-from-number (slot-value info 'return-type)))
289 (vars (loop
290 for arg in args
291 until (eq arg '&rest)
292 collect arg))
293 (rest (cadr (member '&rest args)))
38049b1a 294 (next (make-symbol "ARGS"))
295 (default (make-symbol "DEFAULT")))
9944c385 296
297 `(progn
298 (signal-override-class-closure ',name ',class
299 #'(lambda (,object ,@args)
38049b1a 300 (let ((,default (list* ,object ,@vars ,rest)))
301 (flet ((call-next-handler (&rest ,next)
9944c385 302 (%call-next-handler
e1fcda22 303 ,n-params ',types (or ,next ,default) ',return-type)))
304 ,@body))))
9944c385 305 ',name)))
306
307
e0d2987b 308(defbinding %signal-stop-emission () nil
c8c48a4c 309 (instance ginstance)
e0d2987b 310 (signal-id unsigned-int)
311 (detail quark))
312
313(defvar *signal-stop-emission* nil)
314(declaim (special *signal-stop-emission*))
c8c48a4c 315
e0d2987b 316(defun signal-stop-emission ()
317 (if *signal-stop-emission*
318 (funcall *signal-stop-emission*)
319 (error "Not inside a signal handler")))
320
321
322(defbinding signal-add-emission-hook (type signal function &key (detail 0))
e7225d0f 323 unsigned-long
e0d2987b 324 ((ensure-signal-id-from-type signal type) unsigned-int)
325 (detail quark)
e7225d0f 326 (emission-hook-marshal callback)
e0d2987b 327 ((register-callback-function function) unsigned-int)
56ccd5b7 328 (user-data-destroy-callback callback))
e0d2987b 329
330(defbinding signal-remove-emission-hook (type signal hook-id) nil
331 ((ensure-signal-id-from-type signal type) unsigned-int)
e7225d0f 332 (hook-id unsigned-long))
c8c48a4c 333
c8c48a4c 334
0383dd48 335(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
c8c48a4c 336 (instance signal-id &key detail blocked) boolean
337 (instance ginstance)
e49e135a 338 ((ensure-signal-id signal-id instance) unsigned-int)
c8c48a4c 339 ((or detail 0) quark)
73572c12 340 (blocked boolean))
c8c48a4c 341
e7225d0f 342(defbinding %signal-connect-closure-by-id () unsigned-long
c8c48a4c 343 (instance ginstance)
e0d2987b 344 (signal-id unsigned-int)
345 (detail quark)
346 (closure pointer)
c8c48a4c 347 (after boolean))
348
0383dd48 349(defbinding signal-handler-block () nil
c8c48a4c 350 (instance ginstance)
e7225d0f 351 (handler-id unsigned-long))
c8c48a4c 352
0383dd48 353(defbinding signal-handler-unblock () nil
c8c48a4c 354 (instance ginstance)
e7225d0f 355 (handler-id unsigned-long))
356
357;; Internal
358(defbinding signal-handler-find () unsigned-long
359 (instance gobject)
360 (mask signal-match-type)
361 (signal-id unsigned-int)
362 (detail quark)
363 (closure (or null pointer))
364 (func (or null pointer))
b7c49e0c 365 (data pointer-data))
c8c48a4c 366
0383dd48 367(defbinding signal-handler-disconnect () nil
c8c48a4c 368 (instance ginstance)
e7225d0f 369 (handler-id unsigned-long))
e0d2987b 370
371(defbinding signal-handler-is-connected-p () boolean
372 (instance ginstance)
e7225d0f 373 (handler-id unsigned-long))
c8c48a4c 374
d4f4418a 375(defbinding (closure-new "g_cclosure_new") () gclosure
376 ((make-pointer #xFFFFFFFF) pointer)
e0d2987b 377 (callback-id unsigned-int)
56ccd5b7 378 (destroy-notify callback))
c8c48a4c 379
d4f4418a 380(defbinding closure-set-meta-marshal () nil
381 (gclosure gclosure)
382 (callback-id unsigned-int)
383 (callback callback))
384
385(defun callback-closure-new (callback-id callback destroy-notify)
386 (let ((gclosure (closure-new callback-id destroy-notify)))
387 (closure-set-meta-marshal gclosure callback-id callback)
388 gclosure))
389
b7c49e0c 390(defun make-callback-closure (function &optional (marshaller signal-handler-marshal))
e0d2987b 391 (let ((callback-id (register-callback-function function)))
392 (values
e7225d0f 393 (callback-closure-new callback-id marshaller user-data-destroy-callback)
e0d2987b 394 callback-id)))
395
457f874e 396(defgeneric compute-signal-function (gobject signal function object args))
65670fe5 397
457f874e 398(defmethod compute-signal-function ((gobject gobject) signal function object args)
cd9b9e8b 399 (declare (ignore signal))
e0d2987b 400 (cond
457f874e 401 ((or (eq object t) (eq object gobject))
402 (if args
403 #'(lambda (&rest emission-args)
404 (apply function (nconc emission-args args)))
405 function))
406 (object
407 (if args
408 #'(lambda (&rest emission-args)
409 (apply function object (nconc (rest emission-args) args)))
410 #'(lambda (&rest emission-args)
411 (apply function object (rest emission-args)))))
412 (args
413 #'(lambda (&rest emission-args)
414 (apply function (nconc (rest emission-args) args))))
e0d2987b 415 (t
457f874e 416 #'(lambda (&rest emission-args)
417 (apply function (rest emission-args))))))
cd9b9e8b 418
419(defgeneric compute-signal-id (gobject signal))
420
421(defmethod compute-signal-id ((gobject gobject) signal)
422 (ensure-signal-id signal gobject))
423
424
457f874e 425(defgeneric signal-connect (gobject signal function &key detail after object remove args))
cd9b9e8b 426
427(defmethod signal-connect :around ((gobject gobject) signal function &rest args)
428 (declare (ignore gobject signal args))
429 (when function
430 (call-next-method)))
e0d2987b 431
65670fe5 432
e0d2987b 433(defmethod signal-connect ((gobject gobject) signal function
457f874e 434 &key detail after object remove args)
e0d2987b 435"Connects a callback function to a signal for a particular object. If
436:OBJECT is T, the object connected to is passed as the first argument
437to the callback function, or if :OBJECT is any other non NIL value, it
438is passed as the first argument instead. If :AFTER is non NIL, the
439handler will be called after the default handler for the signal. If
440:REMOVE is non NIL, the handler will be removed after beeing invoked
457f874e 441once. ARGS is a list of additional arguments passed to the callback
442function."
cd9b9e8b 443(let* ((signal-id (compute-signal-id gobject signal))
444 (detail-quark (if detail (quark-intern detail) 0))
445 (signal-stop-emission
446 #'(lambda ()
447 (%signal-stop-emission gobject signal-id detail-quark)))
457f874e 448 (callback (compute-signal-function gobject signal function object args))
cd9b9e8b 449 (wrapper #'(lambda (&rest args)
450 (let ((*signal-stop-emission* signal-stop-emission))
451 (apply callback args)))))
e0d2987b 452 (multiple-value-bind (closure-id callback-id)
e7225d0f 453 (make-callback-closure wrapper signal-handler-marshal)
e0d2987b 454 (let ((handler-id (%signal-connect-closure-by-id
cd9b9e8b 455 gobject signal-id detail-quark closure-id after)))
e0d2987b 456 (when remove
457 (update-user-data callback-id
458 #'(lambda (&rest args)
459 (unwind-protect
460 (let ((*signal-stop-emission* signal-stop-emission))
461 (apply callback args))
e7225d0f 462 (when (signal-handler-is-connected-p gobject handler-id)
463 (signal-handler-disconnect gobject handler-id))))))
cd9b9e8b 464 handler-id))))
e0d2987b 465
466
467;;;; Signal emission
468
469(defbinding %signal-emitv () nil
470 (gvalues pointer)
471 (signal-id unsigned-int)
472 (detail quark)
473 (return-value gvalue))
474
475(defvar *signal-emit-functions* (make-hash-table))
476
477(defun create-signal-emit-function (signal-id)
478 (let ((info (signal-query signal-id)))
479 (let* ((type (type-from-number (slot-value info 'type)))
480 (param-types (cons type (signal-param-types info)))
481 (return-type (type-from-number (slot-value info 'return-type)))
482 (n-params (1+ (slot-value info 'n-params)))
483 (params (allocate-memory (* n-params +gvalue-size+))))
484 #'(lambda (detail object &rest args)
485 (unless (= (length args) (1- n-params))
b4375317 486 (error "Invalid number of arguments in emmision of signal ~A: ~A" signal-id (length args)))
e0d2987b 487 (unwind-protect
488 (loop
489 for arg in (cons object args)
490 for type in param-types
77a843ca 491 as tmp = params then (pointer+ tmp +gvalue-size+)
e0d2987b 492 do (gvalue-init tmp type arg)
493 finally
494 (if return-type
495 (return
496 (with-gvalue (return-value)
497 (%signal-emitv params signal-id detail return-value)))
498 (%signal-emitv params signal-id detail (make-pointer 0))))
499 (loop
500 repeat n-params
77a843ca 501 as tmp = params then (pointer+ tmp +gvalue-size+)
e0d2987b 502 while (gvalue-p tmp)
503 do (gvalue-unset tmp)))))))
504
505(defun signal-emit-with-detail (object signal detail &rest args)
506 (let* ((signal-id (ensure-signal-id signal object))
507 (function (or
508 (gethash signal-id *signal-emit-functions*)
509 (setf
510 (gethash signal-id *signal-emit-functions*)
511 (create-signal-emit-function signal-id)))))
512 (apply function detail object args)))
513
514(defun signal-emit (object signal &rest args)
515 (apply #'signal-emit-with-detail object signal 0 args))
516
c0f178d0 517
457f874e 518;;;; Signal registration
519
520(defbinding %signal-newv (name itype flags return-type param-types)
521 unsigned-int
522 ((signal-name-to-string name) string)
523 (itype gtype)
524 (flags signal-flags)
525 (nil null) ; class closure
526 (nil null) ; accumulator
527 (nil null) ; accumulator data
528 (nil null) ; c marshaller
529 (return-type gtype)
530 ((length param-types) unsigned-int)
531 (param-types (vector gtype)))
532
533(defun signal-new (name itype flags return-type param-types)
534 (when (zerop (signal-lookup name itype))
535 (%signal-newv name itype flags return-type param-types)))
536
fd1e4a39 537;;;; Convenient macros
538
56ccd5b7 539(defmacro define-callback-marshal (name return-type args &key (callback-id :last))
540 (let* ((ignore ())
541 (params ())
542 (names (loop
543 for arg in args
544 collect (if (or
545 (eq arg :ignore)
546 (and (consp arg) (eq (first arg) :ignore)))
547 (let ((name (gensym "IGNORE")))
548 (push name ignore)
549 name)
550 (let ((name (if (atom arg)
551 (gensym (string arg))
552 (first arg))))
553 (push name params)
554 name))))
555 (types (loop
556 for arg in args
557 collect (cond
558 ((eq arg :ignore) 'pointer)
559 ((atom arg) arg)
560 (t (second arg))))))
561 `(define-callback ,name ,return-type
562 ,(ecase callback-id
0146aef0 563 (:first `((callback-id pointer-data) ,@(mapcar #'list names types)))
564 (:last `(,@(mapcar #'list names types) (callback-id pointer-data))))
56ccd5b7 565 (declare (ignore ,@ignore))
248f4dd7 566 (invoke-callback callback-id ',return-type ,@(nreverse params)))))
fd1e4a39 567
568(defmacro with-callback-function ((id function) &body body)
569 `(let ((,id (register-callback-function ,function)))
570 (unwind-protect
571 (progn ,@body)
572 (destroy-user-data ,id))))