chiark / gitweb /
Small change to %DEFBINDING
[clg] / glib / gcallback.lisp
CommitLineData
c8c48a4c 1;; Common Lisp bindings for GTK+ v2.0
2;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
3;;
4;; This library is free software; you can redistribute it and/or
5;; modify it under the terms of the GNU Lesser General Public
6;; License as published by the Free Software Foundation; either
7;; version 2 of the License, or (at your option) any later version.
8;;
9;; This library is distributed in the hope that it will be useful,
10;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12;; Lesser General Public License for more details.
13;;
14;; You should have received a copy of the GNU Lesser General Public
15;; License along with this library; if not, write to the Free Software
16;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17
acd28982 18;; $Id: gcallback.lisp,v 1.16 2004-12-05 13:54:10 espen Exp $
c8c48a4c 19
20(in-package "GLIB")
21
22(use-prefix "g")
23
24
34f9e1d4 25;;;; Callback mechanism
c8c48a4c 26
27(deftype gclosure () 'pointer)
28
34f9e1d4 29(defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
30 (callback-id unsigned-int)
31 (callback pointer)
32 (destroy-notify pointer))
c8c48a4c 33
e378b861 34(defun register-callback-function (function)
35 (check-type function (or null symbol function))
36 (register-user-data function))
c8c48a4c 37
8755b1a5 38(defcallback closure-callback-marshal (nil
39 (gclosure pointer)
40 (return-value gvalue)
41 (n-params unsigned-int)
42 (param-values pointer)
43 (invocation-hint pointer)
44 (callback-id unsigned-int))
34f9e1d4 45 (callback-trampoline callback-id n-params param-values return-value))
c8c48a4c 46
8755b1a5 47(defcallback %destroy-user-data (nil (id unsigned-int))
48 (destroy-user-data id))
34f9e1d4 49
50(defun make-callback-closure (function)
51 (callback-closure-new
52 (register-callback-function function)
53 (callback closure-callback-marshal) (callback %destroy-user-data)))
c8c48a4c 54
c8c48a4c 55
34f9e1d4 56(defun callback-trampoline (callback-id n-params param-values return-value)
c8c48a4c 57 (let* ((return-type (unless (null-pointer-p return-value)
e378b861 58 (gvalue-type return-value)))
34f9e1d4 59 (args (loop
60 for n from 0 below n-params
61 collect (gvalue-get (sap+ param-values (* n +gvalue-size+))))))
62 (let ((result (apply #'invoke-callback callback-id return-type args)))
63 (when return-type
64 (gvalue-set return-value result)))))
65
66
8755b1a5 67(defun invoke-callback (callback-id return-type &rest args)
34f9e1d4 68 (restart-case
69 (apply (find-user-data callback-id) args)
70 (continue nil :report "Return from callback function"
8755b1a5 71 (when return-type
72 (format *query-io* "Enter return value of type ~S: " return-type)
34f9e1d4 73 (force-output *query-io*)
74 (eval (read *query-io*))))
75 (re-invoke nil :report "Re-invoke callback function"
8755b1a5 76 (apply #'invoke-callback callback-id return-type args))))
c8c48a4c 77
c8c48a4c 78
e378b861 79;;;; Timeouts and idle functions
80
acd28982 81(defconstant +priority-high+ -100)
82(defconstant +priority-default+ 0)
83(defconstant +priority-high-idle+ 100)
84(defconstant +priority-default-idle+ 200)
85(defconstant +priority-low+ 300)
86
87(defbinding source-remove () boolean
88 (tag unsigned-int))
89
8755b1a5 90(defcallback source-callback-marshal (nil (callback-id unsigned-int))
34f9e1d4 91 (callback-trampoline callback-id 0 nil (make-pointer 0)))
e378b861 92
93(defbinding (timeout-add "g_timeout_add_full")
acd28982 94 (interval function &optional (priority +priority-default+)) unsigned-int
e378b861 95 (priority int)
96 (interval unsigned-int)
acd28982 97 ((callback source-callback-marshal) pointer)
e378b861 98 ((register-callback-function function) unsigned-long)
34f9e1d4 99 ((callback %destroy-user-data) pointer))
e378b861 100
acd28982 101(defun timeout-remove (timeout)
102 (source-remove timeout))
103
e378b861 104(defbinding (idle-add "g_idle_add_full")
acd28982 105 (function &optional (priority +priority-default-idle+)) unsigned-int
e378b861 106 (priority int)
acd28982 107 ((callback source-callback-marshal) pointer)
e378b861 108 ((register-callback-function function) unsigned-long)
34f9e1d4 109 ((callback %destroy-user-data) pointer))
e378b861 110
acd28982 111(defun idle-remove (idle)
112 (source-remove idle))
e378b861 113
c8c48a4c 114
115;;;; Signals
116
0383dd48 117(defbinding signal-lookup (name itype) unsigned-int
c8c48a4c 118 ((signal-name-to-string name) string)
119 (itype type-number))
120
0383dd48 121(defbinding signal-name () string
c8c48a4c 122 (signal-id unsigned-int))
123
e49e135a 124(defun ensure-signal-id (signal-id instance)
c8c48a4c 125 (etypecase signal-id
126 (integer signal-id)
127 (string (signal-lookup signal-id (type-number-of instance)))
128 (symbol (signal-lookup signal-id (type-number-of instance)))))
129
0383dd48 130(defbinding signal-stop-emission (instance signal-id) nil
c8c48a4c 131 (instance ginstance)
e49e135a 132 ((ensure-signal-id signal-id instance) unsigned-int))
c8c48a4c 133
0383dd48 134; (defbinding (signal-add-emisson-hook "g_signal_add_emission_hook_full")
c8c48a4c 135; () unsigned-int
136; (signal-id unsigned-int)
137; (closure gclosure))
138
0383dd48 139; (defbinding signal-remove-emisson-hook () nil
c8c48a4c 140; (signal-id unsigned-int)
141; (hook-id unsigned-int))
142
0383dd48 143(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
c8c48a4c 144 (instance signal-id &key detail blocked) boolean
145 (instance ginstance)
e49e135a 146 ((ensure-signal-id signal-id instance) unsigned-int)
c8c48a4c 147 ((or detail 0) quark)
148 (blocked boolean))
149
0383dd48 150(defbinding (signal-connect-closure "g_signal_connect_closure_by_id")
c8c48a4c 151 (instance signal-id closure &key detail after) unsigned-int
152 (instance ginstance)
e49e135a 153 ((ensure-signal-id signal-id instance) unsigned-int)
c8c48a4c 154 ((or detail 0) quark)
155 (closure gclosure)
156 (after boolean))
157
0383dd48 158(defbinding signal-handler-block () nil
c8c48a4c 159 (instance ginstance)
160 (handler unsigned-int))
161
0383dd48 162(defbinding signal-handler-unblock () nil
c8c48a4c 163 (instance ginstance)
164 (handler unsigned-int))
165
0383dd48 166(defbinding signal-handler-disconnect () nil
c8c48a4c 167 (instance ginstance)
168 (handler unsigned-int))
169
170
6c55b6c4 171(defmethod signal-connect ((gobject gobject) signal function &key after object)
4d83a8a6 172"Connects a callback function to a signal for a particular object. If :OBJECT
173 is T, the object connected to is passed as the first argument to the callback
174 function, or if :OBJECT is any other non NIL value, it is passed as the first
175 argument instead. If :AFTER is non NIL, the handler will be called after the
acd28982 176 default handler for the signal."
0f152c4e 177 (when function
178 (let ((callback-id
179 (make-callback-closure
180 (cond
181 ((or (eq object t) (eq object gobject)) function)
182 ((not object)
183 #'(lambda (&rest args) (apply function (cdr args))))
184 (t
185 #'(lambda (&rest args) (apply function object (rest args))))))))
186 (signal-connect-closure gobject signal callback-id :after after))))
c0f178d0 187
188
189;;; Message logging
190
191;; TODO: define and signal conditions based on log-level
34f9e1d4 192;(defun log-handler (domain log-level message)
9adccb27 193(def-callback log-handler (c-call:void (domain c-call:c-string)
194 (log-level c-call:int)
195 (message c-call:c-string))
c0f178d0 196 (error "~A: ~A" domain message))
197
34f9e1d4 198(setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))
fd1e4a39 199
200
201;;;; Convenient macros
202
203(defmacro def-callback-marshal (name (return-type &rest args))
204 (let ((names (loop
205 for arg in args
206 collect (if (atom arg) (gensym) (first arg))))
207 (types (loop
208 for arg in args
209 collect (if (atom arg) arg (second arg)))))
210 `(defcallback ,name (,return-type ,@(mapcar #'list names types)
211 (callback-id unsigned-int))
212 (invoke-callback callback-id ',return-type ,@names))))
213
214(defmacro with-callback-function ((id function) &body body)
215 `(let ((,id (register-callback-function ,function)))
216 (unwind-protect
217 (progn ,@body)
218 (destroy-user-data ,id))))
219
220