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.16 2004-12-05 13:54:10 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 (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)
87 (defbinding source-remove () boolean
90 (defcallback source-callback-marshal (nil (callback-id unsigned-int))
91 (callback-trampoline callback-id 0 nil (make-pointer 0)))
93 (defbinding (timeout-add "g_timeout_add_full")
94 (interval function &optional (priority +priority-default+)) unsigned-int
96 (interval unsigned-int)
97 ((callback source-callback-marshal) pointer)
98 ((register-callback-function function) unsigned-long)
99 ((callback %destroy-user-data) pointer))
101 (defun timeout-remove (timeout)
102 (source-remove timeout))
104 (defbinding (idle-add "g_idle_add_full")
105 (function &optional (priority +priority-default-idle+)) unsigned-int
107 ((callback source-callback-marshal) pointer)
108 ((register-callback-function function) unsigned-long)
109 ((callback %destroy-user-data) pointer))
111 (defun idle-remove (idle)
112 (source-remove idle))
117 (defbinding signal-lookup (name itype) unsigned-int
118 ((signal-name-to-string name) string)
121 (defbinding signal-name () string
122 (signal-id unsigned-int))
124 (defun ensure-signal-id (signal-id instance)
127 (string (signal-lookup signal-id (type-number-of instance)))
128 (symbol (signal-lookup signal-id (type-number-of instance)))))
130 (defbinding signal-stop-emission (instance signal-id) nil
132 ((ensure-signal-id signal-id instance) unsigned-int))
134 ; (defbinding (signal-add-emisson-hook "g_signal_add_emission_hook_full")
136 ; (signal-id unsigned-int)
137 ; (closure gclosure))
139 ; (defbinding signal-remove-emisson-hook () nil
140 ; (signal-id unsigned-int)
141 ; (hook-id unsigned-int))
143 (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
144 (instance signal-id &key detail blocked) boolean
146 ((ensure-signal-id signal-id instance) unsigned-int)
147 ((or detail 0) quark)
150 (defbinding (signal-connect-closure "g_signal_connect_closure_by_id")
151 (instance signal-id closure &key detail after) unsigned-int
153 ((ensure-signal-id signal-id instance) unsigned-int)
154 ((or detail 0) quark)
158 (defbinding signal-handler-block () nil
160 (handler unsigned-int))
162 (defbinding signal-handler-unblock () nil
164 (handler unsigned-int))
166 (defbinding signal-handler-disconnect () nil
168 (handler unsigned-int))
171 (defmethod signal-connect ((gobject gobject) signal function &key after object)
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
176 default handler for the signal."
179 (make-callback-closure
181 ((or (eq object t) (eq object gobject)) function)
183 #'(lambda (&rest args) (apply function (cdr args))))
185 #'(lambda (&rest args) (apply function object (rest args))))))))
186 (signal-connect-closure gobject signal callback-id :after after))))
191 ;; TODO: define and signal conditions based on log-level
192 ;(defun log-handler (domain log-level message)
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))
196 (error "~A: ~A" domain message))
198 (setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))
201 ;;;; Convenient macros
203 (defmacro def-callback-marshal (name (return-type &rest args))
206 collect (if (atom arg) (gensym) (first arg))))
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))))
214 (defmacro with-callback-function ((id function) &body body)
215 `(let ((,id (register-callback-function ,function)))
218 (destroy-user-data ,id))))