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.11 2004-11-01 00:08:49 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 (def-callback closure-callback-marshal
39 (void (gclosure system-area-pointer) (return-value system-area-pointer)
40 (n-params unsigned-int) (param-values system-area-pointer)
41 (invocation-hint system-area-pointer) (callback-id unsigned-int))
42 (callback-trampoline callback-id n-params param-values return-value))
44 (def-callback %destroy-user-data (void (id unsigned-int))
45 (destroy-user-data id))
47 (defun make-callback-closure (function)
49 (register-callback-function function)
50 (callback closure-callback-marshal) (callback %destroy-user-data)))
53 (defun callback-trampoline (callback-id n-params param-values return-value)
54 (let* ((return-type (unless (null-pointer-p return-value)
55 (gvalue-type return-value)))
57 for n from 0 below n-params
58 collect (gvalue-get (sap+ param-values (* n +gvalue-size+))))))
59 (let ((result (apply #'invoke-callback callback-id return-type args)))
61 (gvalue-set return-value result)))))
64 (defun invoke-callback (callback-id type &rest args)
66 (apply (find-user-data callback-id) args)
67 (continue nil :report "Return from callback function"
69 (format *query-io* "Enter return value of type ~S: " type)
70 (force-output *query-io*)
71 (eval (read *query-io*))))
72 (re-invoke nil :report "Re-invoke callback function"
73 (apply #'invoke-callback callback-id type args))))
76 ;;;; Timeouts and idle functions
78 (def-callback source-callback-marshal (void (callback-id unsigned-int))
79 (callback-trampoline callback-id 0 nil (make-pointer 0)))
81 (defbinding (timeout-add "g_timeout_add_full")
82 (function interval &optional (priority 0)) unsigned-int
84 (interval unsigned-int)
85 (*source-callback-marshal* pointer)
86 ((register-callback-function function) unsigned-long)
87 ((callback %destroy-user-data) pointer))
89 (defbinding (idle-add "g_idle_add_full")
90 (function &optional (priority 0)) unsigned-int
92 (*source-callback-marshal* pointer)
93 ((register-callback-function function) unsigned-long)
94 ((callback %destroy-user-data) pointer))
100 (defbinding signal-lookup (name itype) unsigned-int
101 ((signal-name-to-string name) string)
104 (defbinding signal-name () string
105 (signal-id unsigned-int))
107 (defun ensure-signal-id (signal-id instance)
110 (string (signal-lookup signal-id (type-number-of instance)))
111 (symbol (signal-lookup signal-id (type-number-of instance)))))
113 (defbinding signal-stop-emission (instance signal-id) nil
115 ((ensure-signal-id signal-id instance) unsigned-int))
117 ; (defbinding (signal-add-emisson-hook "g_signal_add_emission_hook_full")
119 ; (signal-id unsigned-int)
120 ; (closure gclosure))
122 ; (defbinding signal-remove-emisson-hook () nil
123 ; (signal-id unsigned-int)
124 ; (hook-id unsigned-int))
126 (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
127 (instance signal-id &key detail blocked) boolean
129 ((ensure-signal-id signal-id instance) unsigned-int)
130 ((or detail 0) quark)
133 (defbinding (signal-connect-closure "g_signal_connect_closure_by_id")
134 (instance signal-id closure &key detail after) unsigned-int
136 ((ensure-signal-id signal-id instance) unsigned-int)
137 ((or detail 0) quark)
141 (defbinding signal-handler-block () nil
143 (handler unsigned-int))
145 (defbinding signal-handler-unblock () nil
147 (handler unsigned-int))
149 (defbinding signal-handler-disconnect () nil
151 (handler unsigned-int))
154 (defmethod signal-connect ((gobject gobject) signal function &key after object)
155 "Connects a callback function to a signal for a particular object. If :OBJECT
156 is T, the object connected to is passed as the first argument to the callback
157 function, or if :OBJECT is any other non NIL value, it is passed as the first
158 argument instead. If :AFTER is non NIL, the handler will be called after the
159 default handler of the signal."
161 (make-callback-closure
163 ((or (eq object t) (eq object gobject)) function)
165 #'(lambda (&rest args) (apply function (cdr args))))
167 #'(lambda (&rest args) (apply function object (rest args))))))))
168 (signal-connect-closure gobject signal callback-id :after after)))
173 ;; TODO: define and signal conditions based on log-level
174 ;(defun log-handler (domain log-level message)
175 (def-callback log-handler (void (domain c-string) (log-level int)
177 (error "~A: ~A" domain message))
179 (setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))