chiark / gitweb /
Updates for SBCL 0.9.14 and 0.9.15
[clg] / glib / gcallback.lisp
CommitLineData
55212af1 1;; Common Lisp bindings for GTK+ v2.x
2;; Copyright 2000 Espen S. Johnsen <espen@users.sf.net>
c9819f3e 3;;
55212af1 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:
c9819f3e 11;;
55212af1 12;; The above copyright notice and this permission notice shall be
13;; included in all copies or substantial portions of the Software.
c9819f3e 14;;
55212af1 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
26109728 23;; $Id: gcallback.lisp,v 1.36 2006/07/14 10:51:07 espen Exp $
c9819f3e 24
25(in-package "GLIB")
26
27(use-prefix "g")
28
29
3b8e5eb0 30;;;; Callback invokation
c9819f3e 31
f7573853 32(deftype gclosure () 'pointer)
33(register-type 'gclosure '|g_closure_get_type|)
34
60cfb912 35(defun register-callback-function (function)
36 (check-type function (or null symbol function))
37 (register-user-data function))
c9819f3e 38
26109728 39;; Callback marshaller for regular signal handlers
40(define-callback signal-handler-marshal nil
a92553bd 41 ((gclosure gclosure) (return-value gvalue) (n-params unsigned-int)
42 (param-values pointer) (invocation-hint pointer)
26109728 43 (callback-id unsigned-long))
08d14e5e 44 (declare (ignore gclosure invocation-hint))
26109728 45 (callback-trampoline #'invoke-signal-handler callback-id n-params param-values return-value))
c9819f3e 46
26109728 47;; Callback marshaller for class handlers
48(define-callback class-handler-marshal nil
49 ((gclosure gclosure) (return-value gvalue) (n-params unsigned-int)
50 (param-values pointer) (invocation-hint pointer)
51 (callback-id unsigned-long))
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
a92553bd 57 ((invocation-hint pointer) (n-params unsigned-int) (param-values pointer)
26109728 58 (callback-id unsigned-long))
f84e7a8e 59 (declare (ignore invocation-hint))
26109728 60 (callback-trampoline #'invoke-callback callback-id n-params param-values))
3b8e5eb0 61
26109728 62(defun callback-trampoline (restart-wrapper callback-id n-params param-values
63 &optional (return-value (make-pointer 0)))
c9819f3e 64 (let* ((return-type (unless (null-pointer-p return-value)
60cfb912 65 (gvalue-type return-value)))
831668e8 66 (args (loop
67 for n from 0 below n-params
ad112f20 68 for offset from 0 by +gvalue-size+
10ede675 69 collect (gvalue-peek (pointer+ param-values offset)))))
ad112f20 70 (unwind-protect
26109728 71 (multiple-value-bind (result aborted-p)
72 (apply restart-wrapper callback-id nil args)
73 (when (and return-type (not aborted-p))
ad112f20 74 (gvalue-set return-value result)))
10ede675 75 ;; TODO: this should be made more general, by adding a type
26109728 76 ;; method to return invalidating functions.
ad112f20 77 (loop
78 for arg in args
10ede675 79 when (typep arg 'struct)
ad112f20 80 do (invalidate-instance arg)))))
81
26109728 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)
90 (abort () :report "Disconnect and exit signal handler"
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))))
831668e8 96
7bde5a67 97(defun invoke-callback (callback-id return-type &rest args)
26109728 98 (restart-case (apply (find-user-data callback-id) args)
831668e8 99 (continue nil :report "Return from callback function"
26109728 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))))
831668e8 106 (re-invoke nil :report "Re-invoke callback function"
26109728 107 (apply #'invoke-callback callback-id return-type args))))
c9819f3e 108
c9819f3e 109
60cfb912 110;;;; Timeouts and idle functions
111
0f2fb864 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
a92553bd 121(define-callback source-callback-marshal nil ((callback-id unsigned-int))
3b8e5eb0 122 (callback-trampoline callback-id 0 nil))
60cfb912 123
124(defbinding (timeout-add "g_timeout_add_full")
0f2fb864 125 (interval function &optional (priority +priority-default+)) unsigned-int
60cfb912 126 (priority int)
127 (interval unsigned-int)
a92553bd 128 (source-callback-marshal callback)
60cfb912 129 ((register-callback-function function) unsigned-long)
a92553bd 130 (user-data-destroy-callback callback))
60cfb912 131
0f2fb864 132(defun timeout-remove (timeout)
133 (source-remove timeout))
134
60cfb912 135(defbinding (idle-add "g_idle_add_full")
0f2fb864 136 (function &optional (priority +priority-default-idle+)) unsigned-int
60cfb912 137 (priority int)
a92553bd 138 (source-callback-marshal callback)
60cfb912 139 ((register-callback-function function) unsigned-long)
a92553bd 140 (user-data-destroy-callback callback))
60cfb912 141
0f2fb864 142(defun idle-remove (idle)
143 (source-remove idle))
60cfb912 144
c9819f3e 145
3b8e5eb0 146;;;; Signal information querying
c9819f3e 147
3b8e5eb0 148(defbinding signal-lookup (name type) unsigned-int
c9819f3e 149 ((signal-name-to-string name) string)
3b8e5eb0 150 ((find-type-number type t) type-number))
c9819f3e 151
3b8e5eb0 152(defbinding signal-name () (copy-of string)
c9819f3e 153 (signal-id unsigned-int))
154
3b8e5eb0 155(defbinding signal-list-ids (type) (vector unsigned-int n-ids)
156 ((find-type-number type t) type-number)
157 (n-ids unsigned-int :out))
158
159(defun signal-list-names (type)
160 (map 'list #'signal-name (signal-list-ids type)))
161
162(defun ensure-signal-id-from-type (signal-id type)
c9819f3e 163 (etypecase signal-id
3b8e5eb0 164 (integer (if (signal-name signal-id)
165 signal-id
166 (error "Invalid signal id: ~D" signal-id)))
167 ((or symbol string)
168 (let ((numeric-id (signal-lookup signal-id type)))
169 (if (zerop numeric-id)
170 (error "Invalid signal name for ~S: ~D" type signal-id)
171 numeric-id)))))
172
173(defun ensure-signal-id (signal-id instance)
174 (ensure-signal-id-from-type signal-id (type-of instance)))
c9819f3e 175
3b8e5eb0 176(eval-when (:compile-toplevel :load-toplevel :execute)
177 (deftype signal-flags ()
178 '(flags :run-first :run-last :run-cleanup :no-recurse
179 :detailed :action :no-hooks))
180
26109728 181 (define-flags-type signal-match-type
182 :id :detail :closure :func :data :unblocked)
183
3b8e5eb0 184 (defclass signal-query (struct)
185 ((id :allocation :alien :type unsigned-int)
186 (name :allocation :alien :type (copy-of string))
187 (type :allocation :alien :type type-number)
188 (flags :allocation :alien :type signal-flags)
189 (return-type :allocation :alien :type type-number)
190 (n-params :allocation :alien :type unsigned-int)
191 (param-types :allocation :alien :type pointer))
192 (:metaclass struct-class)))
193
194(defbinding signal-query
195 (signal-id &optional (signal-query (make-instance 'signal-query))) nil
196 (signal-id unsigned-int)
10ede675 197 (signal-query signal-query :in/return))
3b8e5eb0 198
199(defun signal-param-types (info)
200 (with-slots (n-params param-types) info
201 (map-c-vector 'list
202 #'(lambda (type-number)
203 (type-from-number type-number))
204 param-types 'type-number n-params)))
205
206
207(defun describe-signal (signal-id &optional type)
208 (let ((info (signal-query (ensure-signal-id-from-type signal-id type))))
209 (with-slots (id name type flags return-type n-params) info
210 (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))
211 (format t "Signal handlers should return ~A and take ~A~%"
212 (cond
213 ((= return-type (find-type-number "void")) "no values")
214 ((not (type-from-number return-type)) "values of unknown type")
215 ((format nil "values of type ~S" (type-from-number return-type))))
216 (if (zerop n-params)
217 "no arguments"
218 (format nil "arguments with the following types: ~A"
219 (signal-param-types info)))))))
220
221
222;;;; Signal connecting and controlling
223
2d3de529 224(defvar *overridden-signals* (make-hash-table :test 'equalp))
225
226(defbinding %signal-override-class-closure () nil
227 (signal-id unsigned-int)
228 (type-number type-number)
229 (callback-closure pointer))
230
231
232(defun signal-override-class-closure (name type function)
233 (let* ((signal-id (ensure-signal-id-from-type name type))
234 (type-number (find-type-number type t))
235 (callback-id (gethash (cons type-number signal-id) *overridden-signals*)))
236 (if callback-id
237 (update-user-data callback-id function)
238 (multiple-value-bind (callback-closure callback-id)
26109728 239 (make-callback-closure function class-handler-marshal)
2d3de529 240 (%signal-override-class-closure signal-id type-number callback-closure)
241 (setf
242 (gethash (cons type-number signal-id) *overridden-signals*)
243 callback-id)))))
244
245
246(defbinding %signal-chain-from-overridden () nil
247 (args pointer)
248 (return-value (or null gvalue)))
249
e9151788 250
251(defun %call-next-handler (n-params types args return-type)
2d3de529 252 (let ((params (allocate-memory (* n-params +gvalue-size+))))
253 (loop
e9151788 254 for arg in args
2d3de529 255 for type in types
256 for offset from 0 by +gvalue-size+
10ede675 257 do (gvalue-init (pointer+ params offset) type arg))
2d3de529 258
259 (unwind-protect
260 (if return-type
261 (with-gvalue (return-value return-type)
262 (%signal-chain-from-overridden params return-value))
263 (%signal-chain-from-overridden params nil))
264 (progn
265 (loop
266 repeat n-params
267 for offset from 0 by +gvalue-size+
10ede675 268 do (gvalue-unset (pointer+ params offset)))
2d3de529 269 (deallocate-memory params)))))
270
271
272(defmacro define-signal-handler (name ((object class) &rest args) &body body)
273 (let* ((info (signal-query (ensure-signal-id-from-type name class)))
274 (types (cons class (signal-param-types info)))
275 (n-params (1+ (slot-value info 'n-params)))
276 (return-type (type-from-number (slot-value info 'return-type)))
277 (vars (loop
278 for arg in args
279 until (eq arg '&rest)
280 collect arg))
281 (rest (cadr (member '&rest args)))
e9151788 282 (next (make-symbol "ARGS"))
283 (default (make-symbol "DEFAULT")))
2d3de529 284
285 `(progn
286 (signal-override-class-closure ',name ',class
287 #'(lambda (,object ,@args)
e9151788 288 (let ((,default (list* ,object ,@vars ,rest)))
289 (flet ((call-next-handler (&rest ,next)
2d3de529 290 (%call-next-handler
2e8019d5 291 ,n-params ',types (or ,next ,default) ',return-type)))
292 ,@body))))
2d3de529 293 ',name)))
294
295
3b8e5eb0 296(defbinding %signal-stop-emission () nil
c9819f3e 297 (instance ginstance)
3b8e5eb0 298 (signal-id unsigned-int)
299 (detail quark))
300
301(defvar *signal-stop-emission* nil)
302(declaim (special *signal-stop-emission*))
c9819f3e 303
3b8e5eb0 304(defun signal-stop-emission ()
305 (if *signal-stop-emission*
306 (funcall *signal-stop-emission*)
307 (error "Not inside a signal handler")))
308
309
310(defbinding signal-add-emission-hook (type signal function &key (detail 0))
26109728 311 unsigned-long
3b8e5eb0 312 ((ensure-signal-id-from-type signal type) unsigned-int)
313 (detail quark)
26109728 314 (emission-hook-marshal callback)
3b8e5eb0 315 ((register-callback-function function) unsigned-int)
a92553bd 316 (user-data-destroy-callback callback))
3b8e5eb0 317
318(defbinding signal-remove-emission-hook (type signal hook-id) nil
319 ((ensure-signal-id-from-type signal type) unsigned-int)
26109728 320 (hook-id unsigned-long))
c9819f3e 321
c9819f3e 322
3f4249c7 323(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
c9819f3e 324 (instance signal-id &key detail blocked) boolean
325 (instance ginstance)
7eec806d 326 ((ensure-signal-id signal-id instance) unsigned-int)
c9819f3e 327 ((or detail 0) quark)
3d36c5d6 328 (blocked boolean))
c9819f3e 329
26109728 330(defbinding %signal-connect-closure-by-id () unsigned-long
c9819f3e 331 (instance ginstance)
3b8e5eb0 332 (signal-id unsigned-int)
333 (detail quark)
334 (closure pointer)
c9819f3e 335 (after boolean))
336
3f4249c7 337(defbinding signal-handler-block () nil
c9819f3e 338 (instance ginstance)
26109728 339 (handler-id unsigned-long))
c9819f3e 340
3f4249c7 341(defbinding signal-handler-unblock () nil
c9819f3e 342 (instance ginstance)
26109728 343 (handler-id unsigned-long))
344
345;; Internal
346(defbinding signal-handler-find () unsigned-long
347 (instance gobject)
348 (mask signal-match-type)
349 (signal-id unsigned-int)
350 (detail quark)
351 (closure (or null pointer))
352 (func (or null pointer))
353 (data unsigned-long))
c9819f3e 354
3f4249c7 355(defbinding signal-handler-disconnect () nil
c9819f3e 356 (instance ginstance)
26109728 357 (handler-id unsigned-long))
3b8e5eb0 358
359(defbinding signal-handler-is-connected-p () boolean
360 (instance ginstance)
26109728 361 (handler-id unsigned-long))
c9819f3e 362
bde4e068 363(defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
3b8e5eb0 364 (callback-id unsigned-int)
a92553bd 365 (callback callback)
366 (destroy-notify callback))
c9819f3e 367
26109728 368(defun make-callback-closure (function marshaller)
3b8e5eb0 369 (let ((callback-id (register-callback-function function)))
370 (values
26109728 371 (callback-closure-new callback-id marshaller user-data-destroy-callback)
3b8e5eb0 372 callback-id)))
373
54ea42fe 374(defgeneric compute-signal-function (gobject signal function object))
a6e13fb0 375
54ea42fe 376(defmethod compute-signal-function ((gobject gobject) signal function object)
377 (declare (ignore signal))
3b8e5eb0 378 (cond
54ea42fe 379 ((or (eq object t) (eq object gobject)) function)
380 ((not object)
3b8e5eb0 381 #'(lambda (&rest args) (apply function (rest args))))
382 (t
54ea42fe 383 #'(lambda (&rest args) (apply function object (rest args))))))
384
385
386(defgeneric compute-signal-id (gobject signal))
387
388(defmethod compute-signal-id ((gobject gobject) signal)
389 (ensure-signal-id signal gobject))
390
391
392(defgeneric signal-connect (gobject signal function &key detail after object remove))
393
394(defmethod signal-connect :around ((gobject gobject) signal function &rest args)
395 (declare (ignore gobject signal args))
396 (when function
397 (call-next-method)))
3b8e5eb0 398
a6e13fb0 399
3b8e5eb0 400(defmethod signal-connect ((gobject gobject) signal function
54ea42fe 401 &key detail after object remove)
3b8e5eb0 402"Connects a callback function to a signal for a particular object. If
403:OBJECT is T, the object connected to is passed as the first argument
404to the callback function, or if :OBJECT is any other non NIL value, it
405is passed as the first argument instead. If :AFTER is non NIL, the
406handler will be called after the default handler for the signal. If
407:REMOVE is non NIL, the handler will be removed after beeing invoked
408once."
54ea42fe 409(let* ((signal-id (compute-signal-id gobject signal))
410 (detail-quark (if detail (quark-intern detail) 0))
411 (signal-stop-emission
412 #'(lambda ()
413 (%signal-stop-emission gobject signal-id detail-quark)))
414 (callback (compute-signal-function gobject signal function object))
415 (wrapper #'(lambda (&rest args)
416 (let ((*signal-stop-emission* signal-stop-emission))
417 (apply callback args)))))
3b8e5eb0 418 (multiple-value-bind (closure-id callback-id)
26109728 419 (make-callback-closure wrapper signal-handler-marshal)
3b8e5eb0 420 (let ((handler-id (%signal-connect-closure-by-id
54ea42fe 421 gobject signal-id detail-quark closure-id after)))
3b8e5eb0 422 (when remove
423 (update-user-data callback-id
424 #'(lambda (&rest args)
425 (unwind-protect
426 (let ((*signal-stop-emission* signal-stop-emission))
427 (apply callback args))
26109728 428 (when (signal-handler-is-connected-p gobject handler-id)
429 (signal-handler-disconnect gobject handler-id))))))
54ea42fe 430 handler-id))))
3b8e5eb0 431
432
433;;;; Signal emission
434
435(defbinding %signal-emitv () nil
436 (gvalues pointer)
437 (signal-id unsigned-int)
438 (detail quark)
439 (return-value gvalue))
440
441(defvar *signal-emit-functions* (make-hash-table))
442
443(defun create-signal-emit-function (signal-id)
444 (let ((info (signal-query signal-id)))
445 (let* ((type (type-from-number (slot-value info 'type)))
446 (param-types (cons type (signal-param-types info)))
447 (return-type (type-from-number (slot-value info 'return-type)))
448 (n-params (1+ (slot-value info 'n-params)))
449 (params (allocate-memory (* n-params +gvalue-size+))))
450 #'(lambda (detail object &rest args)
451 (unless (= (length args) (1- n-params))
452 (error "Invalid number of arguments: ~A" (+ 2 (length args))))
453 (unwind-protect
454 (loop
455 for arg in (cons object args)
456 for type in param-types
10ede675 457 as tmp = params then (pointer+ tmp +gvalue-size+)
3b8e5eb0 458 do (gvalue-init tmp type arg)
459 finally
460 (if return-type
461 (return
462 (with-gvalue (return-value)
463 (%signal-emitv params signal-id detail return-value)))
464 (%signal-emitv params signal-id detail (make-pointer 0))))
465 (loop
466 repeat n-params
10ede675 467 as tmp = params then (pointer+ tmp +gvalue-size+)
3b8e5eb0 468 while (gvalue-p tmp)
469 do (gvalue-unset tmp)))))))
470
471(defun signal-emit-with-detail (object signal detail &rest args)
472 (let* ((signal-id (ensure-signal-id signal object))
473 (function (or
474 (gethash signal-id *signal-emit-functions*)
475 (setf
476 (gethash signal-id *signal-emit-functions*)
477 (create-signal-emit-function signal-id)))))
478 (apply function detail object args)))
479
480(defun signal-emit (object signal &rest args)
481 (apply #'signal-emit-with-detail object signal 0 args))
482
dd181a20 483
11e1e57c 484;;;; Convenient macros
485
a92553bd 486(defmacro define-callback-marshal (name return-type args &key (callback-id :last))
487 (let* ((ignore ())
488 (params ())
489 (names (loop
490 for arg in args
491 collect (if (or
492 (eq arg :ignore)
493 (and (consp arg) (eq (first arg) :ignore)))
494 (let ((name (gensym "IGNORE")))
495 (push name ignore)
496 name)
497 (let ((name (if (atom arg)
498 (gensym (string arg))
499 (first arg))))
500 (push name params)
501 name))))
502 (types (loop
503 for arg in args
504 collect (cond
505 ((eq arg :ignore) 'pointer)
506 ((atom arg) arg)
507 (t (second arg))))))
508 `(define-callback ,name ,return-type
509 ,(ecase callback-id
510 (:first `((callback-id unsigned-int) ,@(mapcar #'list names types)))
511 (:last `(,@(mapcar #'list names types) (callback-id unsigned-int))))
512 (declare (ignore ,@ignore))
ad3e0b2b 513 (invoke-callback callback-id ',return-type ,@(nreverse params)))))
11e1e57c 514
515(defmacro with-callback-function ((id function) &body body)
516 `(let ((,id (register-callback-function ,function)))
517 (unwind-protect
518 (progn ,@body)
519 (destroy-user-data ,id))))