chiark / gitweb /
Renamed dialog class slot vbox to main-area
[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.7 2002-03-24 12:52:11 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 (defbinding signal-lookup (name itype) unsigned-int
109   ((signal-name-to-string name) string)
110   (itype type-number))
111
112 (defbinding signal-name () string
113   (signal-id unsigned-int))
114
115 (defun ensure-signal-id (signal-id instance)
116   (etypecase signal-id
117     (integer signal-id)
118     (string (signal-lookup signal-id (type-number-of instance)))
119     (symbol (signal-lookup signal-id (type-number-of instance)))))
120   
121 (defbinding signal-stop-emission (instance signal-id) nil
122   (instance ginstance)
123   ((ensure-signal-id signal-id instance) unsigned-int))
124
125 ; (defbinding (signal-add-emisson-hook "g_signal_add_emission_hook_full")
126 ;     () unsigned-int
127 ;   (signal-id unsigned-int)
128 ;   (closure gclosure))
129
130 ; (defbinding signal-remove-emisson-hook () nil
131 ;   (signal-id unsigned-int)
132 ;   (hook-id unsigned-int))
133
134 (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
135     (instance signal-id &key detail blocked) boolean
136   (instance ginstance)
137   ((ensure-signal-id signal-id instance) unsigned-int)
138   ((or detail 0) quark)
139   (blocked boolean))
140     
141 (defbinding (signal-connect-closure "g_signal_connect_closure_by_id")
142     (instance signal-id closure &key detail after) unsigned-int
143   (instance ginstance)
144   ((ensure-signal-id signal-id instance) unsigned-int)
145   ((or detail 0) quark)
146   (closure gclosure)
147   (after boolean))
148
149 (defbinding signal-handler-block () nil
150   (instance ginstance)
151   (handler unsigned-int))
152
153 (defbinding signal-handler-unblock () nil
154   (instance ginstance)
155   (handler unsigned-int))
156
157 (defbinding signal-handler-disconnect () nil
158   (instance ginstance)
159   (handler unsigned-int))
160
161
162 (defmethod signal-connect ((gobject gobject) signal function &rest args &key after object)
163   (declare (ignore signal args after))
164   (cond
165    ((or (eq object t) (eq object gobject)) function)
166    ((not object)
167     #'(lambda (&rest args) (apply function (cdr args))))
168    (t
169     #'(lambda (&rest args) (apply function object (rest args))))))
170
171
172 (defmethod signal-connect :around ((gobject gobject) signal function
173                                    &key after object)
174   (declare (ignore object))
175   (let ((callback-id (make-callback-closure (call-next-method))))
176     (signal-connect-closure gobject signal callback-id :after after)))