chiark / gitweb /
Added args argument to COMPUTE-SIGNAL-FUNCTION and some missing defgenerics
[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
afa01e1b 23;; $Id: gcallback.lisp,v 1.38 2006-09-12 14:00:59 espen Exp $
c8c48a4c 24
25(in-package "GLIB")
26
27(use-prefix "g")
28
29
e0d2987b 30;;;; Callback invokation
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)
e7225d0f 43 (callback-id unsigned-long))
266ca870 44 (declare (ignore gclosure invocation-hint))
e7225d0f 45 (callback-trampoline #'invoke-signal-handler callback-id n-params param-values return-value))
c8c48a4c 46
e7225d0f 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
56ccd5b7 57 ((invocation-hint pointer) (n-params unsigned-int) (param-values pointer)
e7225d0f 58 (callback-id unsigned-long))
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)
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))))
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
56ccd5b7 121(define-callback source-callback-marshal nil ((callback-id unsigned-int))
afa01e1b 122 (callback-trampoline #'invoke-callback callback-id 0 nil))
e378b861 123
124(defbinding (timeout-add "g_timeout_add_full")
acd28982 125 (interval function &optional (priority +priority-default+)) unsigned-int
e378b861 126 (priority int)
127 (interval unsigned-int)
56ccd5b7 128 (source-callback-marshal callback)
e378b861 129 ((register-callback-function function) unsigned-long)
56ccd5b7 130 (user-data-destroy-callback callback))
e378b861 131
acd28982 132(defun timeout-remove (timeout)
133 (source-remove timeout))
134
e378b861 135(defbinding (idle-add "g_idle_add_full")
acd28982 136 (function &optional (priority +priority-default-idle+)) unsigned-int
e378b861 137 (priority 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 idle-remove (idle)
143 (source-remove idle))
e378b861 144
c8c48a4c 145
e0d2987b 146;;;; Signal information querying
c8c48a4c 147
e0d2987b 148(defbinding signal-lookup (name type) unsigned-int
c8c48a4c 149 ((signal-name-to-string name) string)
e0d2987b 150 ((find-type-number type t) type-number))
c8c48a4c 151
e0d2987b 152(defbinding signal-name () (copy-of string)
c8c48a4c 153 (signal-id unsigned-int))
154
e0d2987b 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)
c8c48a4c 163 (etypecase signal-id
e0d2987b 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)))
c8c48a4c 175
e0d2987b 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
e7225d0f 181 (define-flags-type signal-match-type
182 :id :detail :closure :func :data :unblocked)
183
e0d2987b 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)
77a843ca 197 (signal-query signal-query :in/return))
e0d2987b 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
9944c385 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)
e7225d0f 239 (make-callback-closure function class-handler-marshal)
9944c385 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
38049b1a 250
251(defun %call-next-handler (n-params types args return-type)
9944c385 252 (let ((params (allocate-memory (* n-params +gvalue-size+))))
253 (loop
38049b1a 254 for arg in args
9944c385 255 for type in types
256 for offset from 0 by +gvalue-size+
77a843ca 257 do (gvalue-init (pointer+ params offset) type arg))
9944c385 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+
77a843ca 268 do (gvalue-unset (pointer+ params offset)))
9944c385 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)))
38049b1a 282 (next (make-symbol "ARGS"))
283 (default (make-symbol "DEFAULT")))
9944c385 284
285 `(progn
286 (signal-override-class-closure ',name ',class
287 #'(lambda (,object ,@args)
38049b1a 288 (let ((,default (list* ,object ,@vars ,rest)))
289 (flet ((call-next-handler (&rest ,next)
9944c385 290 (%call-next-handler
e1fcda22 291 ,n-params ',types (or ,next ,default) ',return-type)))
292 ,@body))))
9944c385 293 ',name)))
294
295
e0d2987b 296(defbinding %signal-stop-emission () nil
c8c48a4c 297 (instance ginstance)
e0d2987b 298 (signal-id unsigned-int)
299 (detail quark))
300
301(defvar *signal-stop-emission* nil)
302(declaim (special *signal-stop-emission*))
c8c48a4c 303
e0d2987b 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))
e7225d0f 311 unsigned-long
e0d2987b 312 ((ensure-signal-id-from-type signal type) unsigned-int)
313 (detail quark)
e7225d0f 314 (emission-hook-marshal callback)
e0d2987b 315 ((register-callback-function function) unsigned-int)
56ccd5b7 316 (user-data-destroy-callback callback))
e0d2987b 317
318(defbinding signal-remove-emission-hook (type signal hook-id) nil
319 ((ensure-signal-id-from-type signal type) unsigned-int)
e7225d0f 320 (hook-id unsigned-long))
c8c48a4c 321
c8c48a4c 322
0383dd48 323(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
c8c48a4c 324 (instance signal-id &key detail blocked) boolean
325 (instance ginstance)
e49e135a 326 ((ensure-signal-id signal-id instance) unsigned-int)
c8c48a4c 327 ((or detail 0) quark)
73572c12 328 (blocked boolean))
c8c48a4c 329
e7225d0f 330(defbinding %signal-connect-closure-by-id () unsigned-long
c8c48a4c 331 (instance ginstance)
e0d2987b 332 (signal-id unsigned-int)
333 (detail quark)
334 (closure pointer)
c8c48a4c 335 (after boolean))
336
0383dd48 337(defbinding signal-handler-block () nil
c8c48a4c 338 (instance ginstance)
e7225d0f 339 (handler-id unsigned-long))
c8c48a4c 340
0383dd48 341(defbinding signal-handler-unblock () nil
c8c48a4c 342 (instance ginstance)
e7225d0f 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))
c8c48a4c 354
0383dd48 355(defbinding signal-handler-disconnect () nil
c8c48a4c 356 (instance ginstance)
e7225d0f 357 (handler-id unsigned-long))
e0d2987b 358
359(defbinding signal-handler-is-connected-p () boolean
360 (instance ginstance)
e7225d0f 361 (handler-id unsigned-long))
c8c48a4c 362
d4f4418a 363(defbinding (closure-new "g_cclosure_new") () gclosure
364 ((make-pointer #xFFFFFFFF) pointer)
e0d2987b 365 (callback-id unsigned-int)
56ccd5b7 366 (destroy-notify callback))
c8c48a4c 367
d4f4418a 368(defbinding closure-set-meta-marshal () nil
369 (gclosure gclosure)
370 (callback-id unsigned-int)
371 (callback callback))
372
373(defun callback-closure-new (callback-id callback destroy-notify)
374 (let ((gclosure (closure-new callback-id destroy-notify)))
375 (closure-set-meta-marshal gclosure callback-id callback)
376 gclosure))
377
e7225d0f 378(defun make-callback-closure (function marshaller)
e0d2987b 379 (let ((callback-id (register-callback-function function)))
380 (values
e7225d0f 381 (callback-closure-new callback-id marshaller user-data-destroy-callback)
e0d2987b 382 callback-id)))
383
cd9b9e8b 384(defgeneric compute-signal-function (gobject signal function object))
65670fe5 385
cd9b9e8b 386(defmethod compute-signal-function ((gobject gobject) signal function object)
387 (declare (ignore signal))
e0d2987b 388 (cond
cd9b9e8b 389 ((or (eq object t) (eq object gobject)) function)
390 ((not object)
e0d2987b 391 #'(lambda (&rest args) (apply function (rest args))))
392 (t
cd9b9e8b 393 #'(lambda (&rest args) (apply function object (rest args))))))
394
395
396(defgeneric compute-signal-id (gobject signal))
397
398(defmethod compute-signal-id ((gobject gobject) signal)
399 (ensure-signal-id signal gobject))
400
401
402(defgeneric signal-connect (gobject signal function &key detail after object remove))
403
404(defmethod signal-connect :around ((gobject gobject) signal function &rest args)
405 (declare (ignore gobject signal args))
406 (when function
407 (call-next-method)))
e0d2987b 408
65670fe5 409
e0d2987b 410(defmethod signal-connect ((gobject gobject) signal function
cd9b9e8b 411 &key detail after object remove)
e0d2987b 412"Connects a callback function to a signal for a particular object. If
413:OBJECT is T, the object connected to is passed as the first argument
414to the callback function, or if :OBJECT is any other non NIL value, it
415is passed as the first argument instead. If :AFTER is non NIL, the
416handler will be called after the default handler for the signal. If
417:REMOVE is non NIL, the handler will be removed after beeing invoked
418once."
cd9b9e8b 419(let* ((signal-id (compute-signal-id gobject signal))
420 (detail-quark (if detail (quark-intern detail) 0))
421 (signal-stop-emission
422 #'(lambda ()
423 (%signal-stop-emission gobject signal-id detail-quark)))
424 (callback (compute-signal-function gobject signal function object))
425 (wrapper #'(lambda (&rest args)
426 (let ((*signal-stop-emission* signal-stop-emission))
427 (apply callback args)))))
e0d2987b 428 (multiple-value-bind (closure-id callback-id)
e7225d0f 429 (make-callback-closure wrapper signal-handler-marshal)
e0d2987b 430 (let ((handler-id (%signal-connect-closure-by-id
cd9b9e8b 431 gobject signal-id detail-quark closure-id after)))
e0d2987b 432 (when remove
433 (update-user-data callback-id
434 #'(lambda (&rest args)
435 (unwind-protect
436 (let ((*signal-stop-emission* signal-stop-emission))
437 (apply callback args))
e7225d0f 438 (when (signal-handler-is-connected-p gobject handler-id)
439 (signal-handler-disconnect gobject handler-id))))))
cd9b9e8b 440 handler-id))))
e0d2987b 441
442
443;;;; Signal emission
444
445(defbinding %signal-emitv () nil
446 (gvalues pointer)
447 (signal-id unsigned-int)
448 (detail quark)
449 (return-value gvalue))
450
451(defvar *signal-emit-functions* (make-hash-table))
452
453(defun create-signal-emit-function (signal-id)
454 (let ((info (signal-query signal-id)))
455 (let* ((type (type-from-number (slot-value info 'type)))
456 (param-types (cons type (signal-param-types info)))
457 (return-type (type-from-number (slot-value info 'return-type)))
458 (n-params (1+ (slot-value info 'n-params)))
459 (params (allocate-memory (* n-params +gvalue-size+))))
460 #'(lambda (detail object &rest args)
461 (unless (= (length args) (1- n-params))
462 (error "Invalid number of arguments: ~A" (+ 2 (length args))))
463 (unwind-protect
464 (loop
465 for arg in (cons object args)
466 for type in param-types
77a843ca 467 as tmp = params then (pointer+ tmp +gvalue-size+)
e0d2987b 468 do (gvalue-init tmp type arg)
469 finally
470 (if return-type
471 (return
472 (with-gvalue (return-value)
473 (%signal-emitv params signal-id detail return-value)))
474 (%signal-emitv params signal-id detail (make-pointer 0))))
475 (loop
476 repeat n-params
77a843ca 477 as tmp = params then (pointer+ tmp +gvalue-size+)
e0d2987b 478 while (gvalue-p tmp)
479 do (gvalue-unset tmp)))))))
480
481(defun signal-emit-with-detail (object signal detail &rest args)
482 (let* ((signal-id (ensure-signal-id signal object))
483 (function (or
484 (gethash signal-id *signal-emit-functions*)
485 (setf
486 (gethash signal-id *signal-emit-functions*)
487 (create-signal-emit-function signal-id)))))
488 (apply function detail object args)))
489
490(defun signal-emit (object signal &rest args)
491 (apply #'signal-emit-with-detail object signal 0 args))
492
c0f178d0 493
fd1e4a39 494;;;; Convenient macros
495
56ccd5b7 496(defmacro define-callback-marshal (name return-type args &key (callback-id :last))
497 (let* ((ignore ())
498 (params ())
499 (names (loop
500 for arg in args
501 collect (if (or
502 (eq arg :ignore)
503 (and (consp arg) (eq (first arg) :ignore)))
504 (let ((name (gensym "IGNORE")))
505 (push name ignore)
506 name)
507 (let ((name (if (atom arg)
508 (gensym (string arg))
509 (first arg))))
510 (push name params)
511 name))))
512 (types (loop
513 for arg in args
514 collect (cond
515 ((eq arg :ignore) 'pointer)
516 ((atom arg) arg)
517 (t (second arg))))))
518 `(define-callback ,name ,return-type
519 ,(ecase callback-id
520 (:first `((callback-id unsigned-int) ,@(mapcar #'list names types)))
521 (:last `(,@(mapcar #'list names types) (callback-id unsigned-int))))
522 (declare (ignore ,@ignore))
248f4dd7 523 (invoke-callback callback-id ',return-type ,@(nreverse params)))))
fd1e4a39 524
525(defmacro with-callback-function ((id function) &body body)
526 `(let ((,id (register-callback-function ,function)))
527 (unwind-protect
528 (progn ,@body)
529 (destroy-user-data ,id))))