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.10 2004-10-30 19:26:02 espen Exp $
27 (deftype gclosure () 'pointer)
29 (defbinding lisp-callback-closure-new () gclosure
30 (callback-id unsigned-int))
32 (defun register-callback-function (function)
33 (check-type function (or null symbol function))
34 (register-user-data function))
36 (defun make-callback-closure (function)
37 (lisp-callback-closure-new (register-callback-function function)))
40 ;;;; Callback mechanism
42 (defun callback-trampoline (callback-id params return-value)
43 (let* ((return-type (unless (null-pointer-p return-value)
44 (gvalue-type return-value)))
46 (callback-function (find-user-data callback-id)))
48 (destructuring-bind (nparams . param-values) params
50 (push (gvalue-get (sap+ param-values (* n +gvalue-size+))) args)))
52 (labels ((invoke-callback ()
55 (let ((result (apply callback-function (reverse args))))
57 (gvalue-set return-value result))))
59 (continue nil :report "Return from callback function"
63 "Enter return value of type ~S: "
65 (force-output *query-io*)
66 (gvalue-set return-value (eval (read *query-io*)))))
67 (re-invoke nil :report "Re-invoke callback function"
72 ;;;; Timeouts and idle functions
74 (defvar *source-callback-marshal*
75 (system:foreign-symbol-address "source_callback_marshal"))
76 (defvar *destroy-notify*
77 (system:foreign-symbol-address "destroy_notify"))
79 (defbinding (timeout-add "g_timeout_add_full")
80 (function interval &optional (priority 0)) unsigned-int
82 (interval unsigned-int)
83 (*source-callback-marshal* pointer)
84 ((register-callback-function function) unsigned-long)
85 (*destroy-notify* pointer))
87 (defbinding (idle-add "g_idle_add_full")
88 (function &optional (priority 0)) unsigned-int
90 (*source-callback-marshal* pointer)
91 ((register-callback-function function) unsigned-long)
92 (*destroy-notify* pointer))
98 (defbinding signal-lookup (name itype) unsigned-int
99 ((signal-name-to-string name) string)
102 (defbinding signal-name () string
103 (signal-id unsigned-int))
105 (defun ensure-signal-id (signal-id instance)
108 (string (signal-lookup signal-id (type-number-of instance)))
109 (symbol (signal-lookup signal-id (type-number-of instance)))))
111 (defbinding signal-stop-emission (instance signal-id) nil
113 ((ensure-signal-id signal-id instance) unsigned-int))
115 ; (defbinding (signal-add-emisson-hook "g_signal_add_emission_hook_full")
117 ; (signal-id unsigned-int)
118 ; (closure gclosure))
120 ; (defbinding signal-remove-emisson-hook () nil
121 ; (signal-id unsigned-int)
122 ; (hook-id unsigned-int))
124 (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
125 (instance signal-id &key detail blocked) boolean
127 ((ensure-signal-id signal-id instance) unsigned-int)
128 ((or detail 0) quark)
131 (defbinding (signal-connect-closure "g_signal_connect_closure_by_id")
132 (instance signal-id closure &key detail after) unsigned-int
134 ((ensure-signal-id signal-id instance) unsigned-int)
135 ((or detail 0) quark)
139 (defbinding signal-handler-block () nil
141 (handler unsigned-int))
143 (defbinding signal-handler-unblock () nil
145 (handler unsigned-int))
147 (defbinding signal-handler-disconnect () nil
149 (handler unsigned-int))
152 (defmethod signal-connect ((gobject gobject) signal function &key after object)
153 "Connects a callback function to a signal for a particular object. If :OBJECT
154 is T, the object connected to is passed as the first argument to the callback
155 function, or if :OBJECT is any other non NIL value, it is passed as the first
156 argument instead. If :AFTER is non NIL, the handler will be called after the
157 default handler of the signal."
159 (make-callback-closure
161 ((or (eq object t) (eq object gobject)) function)
163 #'(lambda (&rest args) (apply function (cdr args))))
165 #'(lambda (&rest args) (apply function object (rest args))))))))
166 (signal-connect-closure gobject signal callback-id :after after)))
171 ;; TODO: define and signal conditions based on log-level
172 (defun log-handler (domain log-level message)
173 (declare (ignore log-level))
174 (error "~A: ~A" domain message))
179 (defun after-gc-hook ()
181 (extern-alien "callback_trampoline" system-area-pointer)
182 (make-pointer (kernel:get-lisp-obj-address #'callback-trampoline))
183 (extern-alien "destroy_user_data" system-area-pointer)
184 (make-pointer (kernel:get-lisp-obj-address #'destroy-user-data))
185 (extern-alien "log_handler" system-area-pointer)
186 (make-pointer (kernel:get-lisp-obj-address #'log-handler))))
188 (pushnew 'after-gc-hook ext:*after-gc-hooks*)