1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
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.
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.
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
18 ;; $Id: gcallback.lisp,v 1.14 2004-11-07 16:04:21 espen Exp $
25 ;;;; Callback mechanism
27 (deftype gclosure () 'pointer)
29 (defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
30 (callback-id unsigned-int)
32 (destroy-notify pointer))
34 (defun register-callback-function (function)
35 (check-type function (or null symbol function))
36 (register-user-data function))
38 (defcallback closure-callback-marshal (nil
41 (n-params unsigned-int)
42 (param-values pointer)
43 (invocation-hint pointer)
44 (callback-id unsigned-int))
45 (callback-trampoline callback-id n-params param-values return-value))
47 (defcallback %destroy-user-data (nil (id unsigned-int))
48 (destroy-user-data id))
50 (defun make-callback-closure (function)
52 (register-callback-function function)
53 (callback closure-callback-marshal) (callback %destroy-user-data)))
56 (defun callback-trampoline (callback-id n-params param-values return-value)
57 (let* ((return-type (unless (null-pointer-p return-value)
58 (gvalue-type return-value)))
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)))
64 (gvalue-set return-value result)))))
67 (defun invoke-callback (callback-id return-type &rest args)
69 (apply (find-user-data callback-id) args)
70 (continue nil :report "Return from callback function"
72 (format *query-io* "Enter return value of type ~S: " return-type)
73 (force-output *query-io*)
74 (eval (read *query-io*))))
75 (re-invoke nil :report "Re-invoke callback function"
76 (apply #'invoke-callback callback-id return-type args))))
79 ;;;; Timeouts and idle functions
81 (defcallback source-callback-marshal (nil (callback-id unsigned-int))
82 (callback-trampoline callback-id 0 nil (make-pointer 0)))
84 (defbinding (timeout-add "g_timeout_add_full")
85 (function interval &optional (priority 0)) unsigned-int
87 (interval unsigned-int)
88 (*source-callback-marshal* pointer)
89 ((register-callback-function function) unsigned-long)
90 ((callback %destroy-user-data) pointer))
92 (defbinding (idle-add "g_idle_add_full")
93 (function &optional (priority 0)) unsigned-int
95 (*source-callback-marshal* pointer)
96 ((register-callback-function function) unsigned-long)
97 ((callback %destroy-user-data) pointer))
103 (defbinding signal-lookup (name itype) unsigned-int
104 ((signal-name-to-string name) string)
107 (defbinding signal-name () string
108 (signal-id unsigned-int))
110 (defun ensure-signal-id (signal-id instance)
113 (string (signal-lookup signal-id (type-number-of instance)))
114 (symbol (signal-lookup signal-id (type-number-of instance)))))
116 (defbinding signal-stop-emission (instance signal-id) nil
118 ((ensure-signal-id signal-id instance) unsigned-int))
120 ; (defbinding (signal-add-emisson-hook "g_signal_add_emission_hook_full")
122 ; (signal-id unsigned-int)
123 ; (closure gclosure))
125 ; (defbinding signal-remove-emisson-hook () nil
126 ; (signal-id unsigned-int)
127 ; (hook-id unsigned-int))
129 (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
130 (instance signal-id &key detail blocked) boolean
132 ((ensure-signal-id signal-id instance) unsigned-int)
133 ((or detail 0) quark)
136 (defbinding (signal-connect-closure "g_signal_connect_closure_by_id")
137 (instance signal-id closure &key detail after) unsigned-int
139 ((ensure-signal-id signal-id instance) unsigned-int)
140 ((or detail 0) quark)
144 (defbinding signal-handler-block () nil
146 (handler unsigned-int))
148 (defbinding signal-handler-unblock () nil
150 (handler unsigned-int))
152 (defbinding signal-handler-disconnect () nil
154 (handler unsigned-int))
157 (defmethod signal-connect ((gobject gobject) signal function &key after object)
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."
164 (make-callback-closure
166 ((or (eq object t) (eq object gobject)) function)
168 #'(lambda (&rest args) (apply function (cdr args))))
170 #'(lambda (&rest args) (apply function object (rest args))))))))
171 (signal-connect-closure gobject signal callback-id :after after)))
176 ;; TODO: define and signal conditions based on log-level
177 ;(defun log-handler (domain log-level message)
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))
181 (error "~A: ~A" domain message))
183 (setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))
186 ;;;; Convenient macros
188 (defmacro def-callback-marshal (name (return-type &rest args))
191 collect (if (atom arg) (gensym) (first arg))))
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))))
199 (defmacro with-callback-function ((id function) &body body)
200 `(let ((,id (register-callback-function ,function)))
203 (destroy-user-data ,id))))