chiark / gitweb /
Adding reader and writer functions to COPY-OF
[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
fd1e4a39 18;; $Id: gcallback.lisp,v 1.14 2004-11-07 16:04:21 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
8755b1a5 81(defcallback source-callback-marshal (nil (callback-id unsigned-int))
34f9e1d4 82 (callback-trampoline callback-id 0 nil (make-pointer 0)))
e378b861 83
84(defbinding (timeout-add "g_timeout_add_full")
85 (function interval &optional (priority 0)) unsigned-int
86 (priority int)
87 (interval unsigned-int)
88 (*source-callback-marshal* pointer)
89 ((register-callback-function function) unsigned-long)
34f9e1d4 90 ((callback %destroy-user-data) pointer))
e378b861 91
92(defbinding (idle-add "g_idle_add_full")
93 (function &optional (priority 0)) unsigned-int
94 (priority int)
95 (*source-callback-marshal* pointer)
96 ((register-callback-function function) unsigned-long)
34f9e1d4 97 ((callback %destroy-user-data) pointer))
e378b861 98
99
c8c48a4c 100
101;;;; Signals
102
0383dd48 103(defbinding signal-lookup (name itype) unsigned-int
c8c48a4c 104 ((signal-name-to-string name) string)
105 (itype type-number))
106
0383dd48 107(defbinding signal-name () string
c8c48a4c 108 (signal-id unsigned-int))
109
e49e135a 110(defun ensure-signal-id (signal-id instance)
c8c48a4c 111 (etypecase signal-id
112 (integer signal-id)
113 (string (signal-lookup signal-id (type-number-of instance)))
114 (symbol (signal-lookup signal-id (type-number-of instance)))))
115
0383dd48 116(defbinding signal-stop-emission (instance signal-id) nil
c8c48a4c 117 (instance ginstance)
e49e135a 118 ((ensure-signal-id signal-id instance) unsigned-int))
c8c48a4c 119
0383dd48 120; (defbinding (signal-add-emisson-hook "g_signal_add_emission_hook_full")
c8c48a4c 121; () unsigned-int
122; (signal-id unsigned-int)
123; (closure gclosure))
124
0383dd48 125; (defbinding signal-remove-emisson-hook () nil
c8c48a4c 126; (signal-id unsigned-int)
127; (hook-id unsigned-int))
128
0383dd48 129(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
c8c48a4c 130 (instance signal-id &key detail blocked) boolean
131 (instance ginstance)
e49e135a 132 ((ensure-signal-id signal-id instance) unsigned-int)
c8c48a4c 133 ((or detail 0) quark)
134 (blocked boolean))
135
0383dd48 136(defbinding (signal-connect-closure "g_signal_connect_closure_by_id")
c8c48a4c 137 (instance signal-id closure &key detail after) unsigned-int
138 (instance ginstance)
e49e135a 139 ((ensure-signal-id signal-id instance) unsigned-int)
c8c48a4c 140 ((or detail 0) quark)
141 (closure gclosure)
142 (after boolean))
143
0383dd48 144(defbinding signal-handler-block () nil
c8c48a4c 145 (instance ginstance)
146 (handler unsigned-int))
147
0383dd48 148(defbinding signal-handler-unblock () nil
c8c48a4c 149 (instance ginstance)
150 (handler unsigned-int))
151
0383dd48 152(defbinding signal-handler-disconnect () nil
c8c48a4c 153 (instance ginstance)
154 (handler unsigned-int))
155
156
6c55b6c4 157(defmethod signal-connect ((gobject gobject) signal function &key after object)
4d83a8a6 158"Connects a callback function to a signal for a particular object. If :OBJECT
159 is T, the object connected to is passed as the first argument to the callback
160 function, or if :OBJECT is any other non NIL value, it is passed as the first
161 argument instead. If :AFTER is non NIL, the handler will be called after the
162 default handler of the signal."
6c55b6c4 163 (let ((callback-id
164 (make-callback-closure
165 (cond
166 ((or (eq object t) (eq object gobject)) function)
167 ((not object)
168 #'(lambda (&rest args) (apply function (cdr args))))
169 (t
170 #'(lambda (&rest args) (apply function object (rest args))))))))
631bd04c 171 (signal-connect-closure gobject signal callback-id :after after)))
c0f178d0 172
173
174;;; Message logging
175
176;; TODO: define and signal conditions based on log-level
34f9e1d4 177;(defun log-handler (domain log-level message)
9adccb27 178(def-callback log-handler (c-call:void (domain c-call:c-string)
179 (log-level c-call:int)
180 (message c-call:c-string))
c0f178d0 181 (error "~A: ~A" domain message))
182
34f9e1d4 183(setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))
fd1e4a39 184
185
186;;;; Convenient macros
187
188(defmacro def-callback-marshal (name (return-type &rest args))
189 (let ((names (loop
190 for arg in args
191 collect (if (atom arg) (gensym) (first arg))))
192 (types (loop
193 for arg in args
194 collect (if (atom arg) arg (second arg)))))
195 `(defcallback ,name (,return-type ,@(mapcar #'list names types)
196 (callback-id unsigned-int))
197 (invoke-callback callback-id ',return-type ,@names))))
198
199(defmacro with-callback-function ((id function) &body body)
200 `(let ((,id (register-callback-function ,function)))
201 (unwind-protect
202 (progn ,@body)
203 (destroy-user-data ,id))))
204
205