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