chiark / gitweb /
Moved callback mechanism and signal system from gtk to glib
[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
18;; $Id: gcallback.lisp,v 1.1 2000-11-09 20:29:19 espen Exp $
19
20(in-package "GLIB")
21
22(use-prefix "g")
23
24
25;;;; Closures
26
27(deftype gclosure () 'pointer)
28
29(define-foreign lisp-callback-closure () gclosure
30 (callback-id unsigned-int))
31
32
33
34
35;;;; Callback mechanism
36
37(defun register-callback-function (function)
38 (check-type function (or null symbol function))
39 (lisp-callback-closure (register-user-data function)))
40
41(defun callback-trampoline (callback-id params return-value)
42 (let* ((return-type (unless (null-pointer-p return-value)
43 (type-from-number (gvalue-type return-value))))
44 (args nil)
45 (callback-function (find-user-data callback-id)))
46
47 (destructuring-bind (nparams . param-values) params
48 (dotimes (n nparams)
49 (push (gvalue-value (sap+ param-values (* n +gvalue-size+))) args)))
50
51 (labels ((invoke-callback ()
52 (restart-case
53 (unwind-protect
54 (let ((result (apply callback-function args)))
55 (when return-type
56 (setf (gvalue-value return-value) result))))
57
58 (continue nil :report "Return from callback function"
59 (when return-type
60 (format
61 *query-io*
62 "Enter return value of type ~S: "
63 return-type)
64 (force-output *query-io*)
65 (setf
66 (gvalue-value return-value)
67 (eval (read *query-io*)))))
68 (re-invoke nil :report "Re-invoke callback function"
69 (invoke-callback)))))
70 (invoke-callback))))
71
72(defun after-gc-hook ()
73 (setf
74 (extern-alien "callback_trampoline" system-area-pointer)
75 (make-pointer (kernel:get-lisp-obj-address #'callback-trampoline))
76 (extern-alien "destroy_user_data" system-area-pointer)
77 (make-pointer (kernel:get-lisp-obj-address #'destroy-user-data))))
78
79(pushnew 'after-gc-hook ext:*after-gc-hooks*)
80(after-gc-hook)
81
82
83
84;;;; Signals
85
86(defun signal-name-to-string (name)
87 (substitute #\_ #\- (string-downcase (string name))))
88
89(define-foreign signal-lookup (name itype) unsigned-int
90 ((signal-name-to-string name) string)
91 (itype type-number))
92
93(define-foreign signal-name () string
94 (signal-id unsigned-int))
95
96(defun %ensure-signal-id (signal-id instance)
97 (etypecase signal-id
98 (integer signal-id)
99 (string (signal-lookup signal-id (type-number-of instance)))
100 (symbol (signal-lookup signal-id (type-number-of instance)))))
101
102(define-foreign signal-stop-emission (instance signal-id) nil
103 (instance ginstance)
104 ((%ensure-signal-id signal-id instance) unsigned-int))
105
106; (define-foreign ("g_signal_add_emission_hook_full" signal-add-emisson-hook)
107; () unsigned-int
108; (signal-id unsigned-int)
109; (closure gclosure))
110
111; (define-foreign signal-remove-emisson-hook () nil
112; (signal-id unsigned-int)
113; (hook-id unsigned-int))
114
115(define-foreign ("g_signal_has_handler_pending" signal-has-handler-pending-p)
116 (instance signal-id &key detail blocked) boolean
117 (instance ginstance)
118 ((%ensure-signal-id signal-id instance) unsigned-int)
119 ((or detail 0) quark)
120 (blocked boolean))
121
122(define-foreign ("g_signal_connect_closure_by_id" signal-connect-closure)
123 (instance signal-id closure &key detail after) unsigned-int
124 (instance ginstance)
125 ((%ensure-signal-id signal-id instance) unsigned-int)
126 ((or detail 0) quark)
127 (closure gclosure)
128 (after boolean))
129
130(define-foreign signal-handler-block () nil
131 (instance ginstance)
132 (handler unsigned-int))
133
134(define-foreign signal-handler-unblock () nil
135 (instance ginstance)
136 (handler unsigned-int))
137
138(define-foreign signal-handler-disconnect () nil
139 (instance ginstance)
140 (handler unsigned-int))
141
142
143(defun signal-connect (instance signal function &key after object)
144 (let ((callback
145 (cond
146 ((or (eq object t) (eq object instance)) function)
147 ((not object)
148 #'(lambda (&rest args) (apply function (cdr args))))
149 (t
150 #'(lambda (&rest args) (apply function object (rest args)))))))
151
152 (signal-connect-closure
153 instance signal (register-callback-function callback) :after after)))