chiark / gitweb /
Added timeout-add and idle-add
[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
e378b861 18;; $Id: gcallback.lisp,v 1.6 2002-03-19 17:09:15 espen Exp $
c8c48a4c 19
20(in-package "GLIB")
21
22(use-prefix "g")
23
24
25;;;; Closures
26
27(deftype gclosure () 'pointer)
28
0383dd48 29(defbinding lisp-callback-closure-new () gclosure
c8c48a4c 30 (callback-id unsigned-int))
31
e378b861 32(defun register-callback-function (function)
33 (check-type function (or null symbol function))
34 (register-user-data function))
c8c48a4c 35
e378b861 36(defun make-callback-closure (function)
37 (lisp-callback-closure-new (register-callback-function function)))
c8c48a4c 38
c8c48a4c 39
e378b861 40;;;; Callback mechanism
c8c48a4c 41
42(defun callback-trampoline (callback-id params return-value)
43 (let* ((return-type (unless (null-pointer-p return-value)
e378b861 44 (gvalue-type return-value)))
c8c48a4c 45 (args nil)
46 (callback-function (find-user-data callback-id)))
47
48 (destructuring-bind (nparams . param-values) params
49 (dotimes (n nparams)
e49e135a 50 (push (gvalue-get (sap+ param-values (* n +gvalue-size+))) args)))
c8c48a4c 51
52 (labels ((invoke-callback ()
53 (restart-case
54 (unwind-protect
631bd04c 55 (let ((result (apply callback-function (reverse args))))
c8c48a4c 56 (when return-type
e378b861 57 (gvalue-set (print return-value) result))))
c8c48a4c 58
59 (continue nil :report "Return from callback function"
60 (when return-type
61 (format
62 *query-io*
63 "Enter return value of type ~S: "
64 return-type)
65 (force-output *query-io*)
e49e135a 66 (gvalue-set return-value (eval (read *query-io*)))))
c8c48a4c 67 (re-invoke nil :report "Re-invoke callback function"
68 (invoke-callback)))))
69 (invoke-callback))))
70
71(defun after-gc-hook ()
72 (setf
73 (extern-alien "callback_trampoline" system-area-pointer)
74 (make-pointer (kernel:get-lisp-obj-address #'callback-trampoline))
75 (extern-alien "destroy_user_data" system-area-pointer)
76 (make-pointer (kernel:get-lisp-obj-address #'destroy-user-data))))
77
78(pushnew 'after-gc-hook ext:*after-gc-hooks*)
79(after-gc-hook)
80
81
e378b861 82;;;; Timeouts and idle functions
83
84(defvar *source-callback-marshal*
85 (system:foreign-symbol-address "source_callback_marshal"))
86(defvar *destroy-notify*
87 (system:foreign-symbol-address "destroy_notify"))
88
89(defbinding (timeout-add "g_timeout_add_full")
90 (function interval &optional (priority 0)) unsigned-int
91 (priority int)
92 (interval unsigned-int)
93 (*source-callback-marshal* pointer)
94 ((register-callback-function function) unsigned-long)
95 (*destroy-notify* pointer))
96
97(defbinding (idle-add "g_idle_add_full")
98 (function &optional (priority 0)) unsigned-int
99 (priority int)
100 (*source-callback-marshal* pointer)
101 ((register-callback-function function) unsigned-long)
102 (*destroy-notify* pointer))
103
104
c8c48a4c 105
106;;;; Signals
107
108(defun signal-name-to-string (name)
109 (substitute #\_ #\- (string-downcase (string name))))
110
0383dd48 111(defbinding signal-lookup (name itype) unsigned-int
c8c48a4c 112 ((signal-name-to-string name) string)
113 (itype type-number))
114
0383dd48 115(defbinding signal-name () string
c8c48a4c 116 (signal-id unsigned-int))
117
e49e135a 118(defun ensure-signal-id (signal-id instance)
c8c48a4c 119 (etypecase signal-id
120 (integer signal-id)
121 (string (signal-lookup signal-id (type-number-of instance)))
122 (symbol (signal-lookup signal-id (type-number-of instance)))))
123
0383dd48 124(defbinding signal-stop-emission (instance signal-id) nil
c8c48a4c 125 (instance ginstance)
e49e135a 126 ((ensure-signal-id signal-id instance) unsigned-int))
c8c48a4c 127
0383dd48 128; (defbinding (signal-add-emisson-hook "g_signal_add_emission_hook_full")
c8c48a4c 129; () unsigned-int
130; (signal-id unsigned-int)
131; (closure gclosure))
132
0383dd48 133; (defbinding signal-remove-emisson-hook () nil
c8c48a4c 134; (signal-id unsigned-int)
135; (hook-id unsigned-int))
136
0383dd48 137(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
c8c48a4c 138 (instance signal-id &key detail blocked) boolean
139 (instance ginstance)
e49e135a 140 ((ensure-signal-id signal-id instance) unsigned-int)
c8c48a4c 141 ((or detail 0) quark)
142 (blocked boolean))
143
0383dd48 144(defbinding (signal-connect-closure "g_signal_connect_closure_by_id")
c8c48a4c 145 (instance signal-id closure &key detail after) unsigned-int
146 (instance ginstance)
e49e135a 147 ((ensure-signal-id signal-id instance) unsigned-int)
c8c48a4c 148 ((or detail 0) quark)
149 (closure gclosure)
150 (after boolean))
151
0383dd48 152(defbinding signal-handler-block () nil
c8c48a4c 153 (instance ginstance)
154 (handler unsigned-int))
155
0383dd48 156(defbinding signal-handler-unblock () nil
c8c48a4c 157 (instance ginstance)
158 (handler unsigned-int))
159
0383dd48 160(defbinding signal-handler-disconnect () nil
c8c48a4c 161 (instance ginstance)
162 (handler unsigned-int))
163
164
631bd04c 165(defmethod signal-connect ((gobject gobject) signal function &rest args &key after object)
81594ec4 166 (declare (ignore signal args after))
631bd04c 167 (cond
168 ((or (eq object t) (eq object gobject)) function)
169 ((not object)
170 #'(lambda (&rest args) (apply function (cdr args))))
171 (t
172 #'(lambda (&rest args) (apply function object (rest args))))))
173
174
175(defmethod signal-connect :around ((gobject gobject) signal function
176 &key after object)
81594ec4 177 (declare (ignore object))
e378b861 178 (let ((callback-id (make-callback-closure (call-next-method))))
631bd04c 179 (signal-connect-closure gobject signal callback-id :after after)))