chiark / gitweb /
Added timeout-add and idle-add
[clg] / glib / gcallback.lisp
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
18 ;; $Id: gcallback.lisp,v 1.6 2002-03-19 17:09:15 espen Exp $
19
20 (in-package "GLIB")
21
22 (use-prefix "g")
23
24
25 ;;;; Closures
26
27 (deftype gclosure () 'pointer)
28
29 (defbinding lisp-callback-closure-new () gclosure
30   (callback-id unsigned-int))
31
32 (defun register-callback-function (function)
33   (check-type function (or null symbol function))
34   (register-user-data function))
35
36 (defun make-callback-closure (function)
37   (lisp-callback-closure-new (register-callback-function function)))
38
39
40 ;;;; Callback mechanism
41
42 (defun callback-trampoline (callback-id params return-value)
43   (let* ((return-type (unless (null-pointer-p return-value)
44                         (gvalue-type return-value)))
45          (args nil)
46          (callback-function (find-user-data callback-id)))
47
48     (destructuring-bind (nparams . param-values) params
49       (dotimes (n nparams)
50         (push (gvalue-get (sap+ param-values (* n +gvalue-size+))) args)))
51
52     (labels ((invoke-callback ()
53                (restart-case
54                    (unwind-protect
55                        (let ((result (apply callback-function (reverse args))))
56                          (when return-type
57                            (gvalue-set (print return-value) result))))
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*)
66                     (gvalue-set return-value (eval (read *query-io*)))))
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
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
105
106 ;;;; Signals
107
108 (defun signal-name-to-string (name)
109   (substitute #\_ #\- (string-downcase (string name))))
110
111 (defbinding signal-lookup (name itype) unsigned-int
112   ((signal-name-to-string name) string)
113   (itype type-number))
114
115 (defbinding signal-name () string
116   (signal-id unsigned-int))
117
118 (defun ensure-signal-id (signal-id instance)
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   
124 (defbinding signal-stop-emission (instance signal-id) nil
125   (instance ginstance)
126   ((ensure-signal-id signal-id instance) unsigned-int))
127
128 ; (defbinding (signal-add-emisson-hook "g_signal_add_emission_hook_full")
129 ;     () unsigned-int
130 ;   (signal-id unsigned-int)
131 ;   (closure gclosure))
132
133 ; (defbinding signal-remove-emisson-hook () nil
134 ;   (signal-id unsigned-int)
135 ;   (hook-id unsigned-int))
136
137 (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
138     (instance signal-id &key detail blocked) boolean
139   (instance ginstance)
140   ((ensure-signal-id signal-id instance) unsigned-int)
141   ((or detail 0) quark)
142   (blocked boolean))
143     
144 (defbinding (signal-connect-closure "g_signal_connect_closure_by_id")
145     (instance signal-id closure &key detail after) unsigned-int
146   (instance ginstance)
147   ((ensure-signal-id signal-id instance) unsigned-int)
148   ((or detail 0) quark)
149   (closure gclosure)
150   (after boolean))
151
152 (defbinding signal-handler-block () nil
153   (instance ginstance)
154   (handler unsigned-int))
155
156 (defbinding signal-handler-unblock () nil
157   (instance ginstance)
158   (handler unsigned-int))
159
160 (defbinding signal-handler-disconnect () nil
161   (instance ginstance)
162   (handler unsigned-int))
163
164
165 (defmethod signal-connect ((gobject gobject) signal function &rest args &key after object)
166   (declare (ignore signal args after))
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)
177   (declare (ignore object))
178   (let ((callback-id (make-callback-closure (call-next-method))))
179     (signal-connect-closure gobject signal callback-id :after after)))