560af5c5 |
1 | ;; Common Lisp bindings for GTK+ v2.0 |
82747bbd |
2 | ;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no> |
560af5c5 |
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 | |
21299acf |
18 | ;; $Id: gobject.lisp,v 1.32 2005-02-10 00:20:02 espen Exp $ |
560af5c5 |
19 | |
20 | (in-package "GLIB") |
21 | |
22 | |
2176a9c7 |
23 | ;;;; Metaclass used for subclasses of gobject |
24 | |
25 | (eval-when (:compile-toplevel :load-toplevel :execute) |
26 | (defclass gobject-class (ginstance-class) |
27 | ()) |
28 | |
73572c12 |
29 | (defmethod validate-superclass ((class gobject-class) (super standard-class)) |
2176a9c7 |
30 | ; (subtypep (class-name super) 'gobject) |
31 | t)) |
32 | |
33 | (defclass direct-property-slot-definition (direct-virtual-slot-definition) |
34 | ((pname :reader slot-definition-pname :initarg :pname) |
35 | (readable :initform t :reader slot-readable-p :initarg :readable) |
36 | (writable :initform t :reader slot-writable-p :initarg :writable) |
37 | (construct :initform nil :initarg :construct))) |
38 | |
39 | (defclass effective-property-slot-definition (effective-virtual-slot-definition) |
40 | ((pname :reader slot-definition-pname :initarg :pname) |
41 | (readable :reader slot-readable-p :initarg :readable) |
42 | (writable :reader slot-writable-p :initarg :writable) |
174e8a5c |
43 | (construct :initarg :construct))) |
44 | |
45 | (defclass direct-user-data-slot-definition (direct-virtual-slot-definition) |
46 | ()) |
47 | |
48 | (defclass effective-user-data-slot-definition (effective-virtual-slot-definition) |
49 | ()) |
50 | |
2176a9c7 |
51 | |
52 | (defbinding %object-ref () pointer |
53 | (location pointer)) |
54 | |
55 | (defbinding %object-unref () nil |
56 | (location pointer)) |
57 | |
58 | (defmethod reference-foreign ((class gobject-class) location) |
59 | (declare (ignore class)) |
60 | (%object-ref location)) |
61 | |
62 | (defmethod unreference-foreign ((class gobject-class) location) |
63 | (declare (ignore class)) |
64 | (%object-unref location)) |
65 | |
66 | |
67 | ; (defbinding object-class-install-param () nil |
68 | ; (class pointer) |
69 | ; (id unsigned-int) |
70 | ; (parameter parameter)) |
71 | |
72 | ; (defbinding object-class-find-param-spec () parameter |
73 | ; (class pointer) |
74 | ; (name string)) |
75 | |
76 | (defun signal-name-to-string (name) |
77 | (substitute #\_ #\- (string-downcase (string name)))) |
78 | |
79 | |
80 | (defmethod direct-slot-definition-class ((class gobject-class) &rest initargs) |
81 | (case (getf initargs :allocation) |
82 | (:property (find-class 'direct-property-slot-definition)) |
174e8a5c |
83 | (:user-data (find-class 'direct-user-data-slot-definition)) |
2176a9c7 |
84 | (t (call-next-method)))) |
85 | |
86 | (defmethod effective-slot-definition-class ((class gobject-class) &rest initargs) |
87 | (case (getf initargs :allocation) |
88 | (:property (find-class 'effective-property-slot-definition)) |
174e8a5c |
89 | (:user-data (find-class 'effective-user-data-slot-definition)) |
2176a9c7 |
90 | (t (call-next-method)))) |
91 | |
92 | (defmethod compute-effective-slot-definition-initargs ((class gobject-class) direct-slotds) |
eeda1c2d |
93 | (if (typep (first direct-slotds) 'direct-property-slot-definition) |
2176a9c7 |
94 | (nconc |
95 | (list :pname (signal-name-to-string |
96 | (most-specific-slot-value direct-slotds 'pname)) |
97 | :readable (most-specific-slot-value direct-slotds 'readable) |
98 | :writable (most-specific-slot-value direct-slotds 'writable) |
99 | :construct (most-specific-slot-value direct-slotds 'construct)) |
100 | (call-next-method)) |
101 | (call-next-method))) |
102 | |
103 | |
104 | (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-definition)) |
105 | (let* ((type (slot-definition-type slotd)) |
106 | (pname (slot-definition-pname slotd)) |
107 | (type-number (find-type-number type))) |
eeda1c2d |
108 | (when (and (not (slot-boundp slotd 'getter)) (slot-readable-p slotd)) |
2176a9c7 |
109 | (setf |
eeda1c2d |
110 | (slot-value slotd 'getter) |
21299acf |
111 | (let ((reader nil)) ;(reader-function type))) |
eeda1c2d |
112 | #'(lambda (object) |
21299acf |
113 | (unless reader |
114 | (setq reader (reader-function type))) |
eeda1c2d |
115 | (let ((gvalue (gvalue-new type-number))) |
116 | (%object-get-property object pname gvalue) |
117 | (unwind-protect |
118 | (funcall reader gvalue +gvalue-value-offset+) |
119 | (gvalue-free gvalue t))))))) |
2176a9c7 |
120 | |
eeda1c2d |
121 | (when (and (not (slot-boundp slotd 'setter)) (slot-writable-p slotd)) |
2176a9c7 |
122 | (setf |
eeda1c2d |
123 | (slot-value slotd 'setter) |
21299acf |
124 | (let ((writer nil)) ;(writer-function type))) |
eeda1c2d |
125 | #'(lambda (value object) |
21299acf |
126 | (unless writer |
127 | (setq writer (writer-function type))) |
eeda1c2d |
128 | (let ((gvalue (gvalue-new type-number))) |
129 | (funcall writer value gvalue +gvalue-value-offset+) |
130 | (%object-set-property object pname gvalue) |
131 | (gvalue-free gvalue t) |
132 | value)))))) |
133 | |
2176a9c7 |
134 | (call-next-method)) |
135 | |
174e8a5c |
136 | (defmethod initialize-internal-slot-functions ((slotd effective-user-data-slot-definition)) |
137 | (let ((slot-name (slot-definition-name slotd))) |
56870989 |
138 | (unless (slot-boundp slotd 'getter) |
139 | (setf |
140 | (slot-value slotd 'getter) |
141 | #'(lambda (object) |
142 | (prog1 (user-data object slot-name))))) |
143 | (unless (slot-boundp slotd 'setter) |
144 | (setf |
145 | (slot-value slotd 'setter) |
146 | #'(lambda (value object) |
147 | (setf (user-data object slot-name) value)))) |
148 | (unless (slot-boundp slotd 'boundp) |
149 | (setf |
150 | (slot-value slotd 'boundp) |
151 | #'(lambda (object) |
152 | (user-data-p object slot-name))))) |
174e8a5c |
153 | (call-next-method)) |
154 | |
2176a9c7 |
155 | |
156 | ;;;; Super class for all classes in the GObject type hierarchy |
157 | |
560af5c5 |
158 | (eval-when (:compile-toplevel :load-toplevel :execute) |
c8c48a4c |
159 | (defclass gobject (ginstance) |
560af5c5 |
160 | () |
2176a9c7 |
161 | (:metaclass gobject-class) |
9adccb27 |
162 | (:alien-name "GObject"))) |
163 | |
eeda1c2d |
164 | |
165 | (defun initial-add (object function initargs key pkey) |
166 | (loop |
167 | as (initarg value . rest) = initargs then rest |
168 | do (cond |
169 | ((eq initarg key) (funcall function object value)) |
170 | ((eq initarg pkey) (mapc #'(lambda (value) |
171 | (funcall function object value)) |
172 | value))) |
173 | while rest)) |
174 | |
175 | (defun initial-apply-add (object function initargs key pkey) |
176 | (initial-add object #'(lambda (object value) |
177 | (apply function object (mklist value))) |
178 | initargs key pkey)) |
179 | |
180 | |
82747bbd |
181 | (defmethod initialize-instance ((object gobject) &rest initargs) |
040579dd |
182 | (unless (slot-boundp object 'location) |
183 | ;; Extract initargs which we should pass directly to the GObeject |
184 | ;; constructor |
185 | (let* ((slotds (class-slots (class-of object))) |
186 | (args (when initargs |
187 | (loop |
188 | as (key value . rest) = initargs then rest |
189 | as slotd = (find-if |
190 | #'(lambda (slotd) |
191 | (member key (slot-definition-initargs slotd))) |
192 | slotds) |
193 | when (and (typep slotd 'effective-property-slot-definition) |
194 | (slot-value slotd 'construct)) |
195 | collect (progn |
196 | (remf initargs key) |
197 | (list |
198 | (slot-definition-pname slotd) |
199 | (slot-definition-type slotd) |
200 | value)) |
201 | while rest)))) |
202 | (if args |
203 | (let* ((string-size (size-of 'string)) |
204 | (string-writer (writer-function 'string)) |
205 | (string-destroy (destroy-function 'string)) |
206 | (params (allocate-memory |
207 | (* (length args) (+ string-size +gvalue-size+))))) |
9adccb27 |
208 | (loop |
040579dd |
209 | for (pname type value) in args |
9adccb27 |
210 | as tmp = params then (sap+ tmp (+ string-size +gvalue-size+)) |
040579dd |
211 | do (funcall string-writer pname tmp) |
212 | (gvalue-init (sap+ tmp string-size) type value)) |
213 | (unwind-protect |
214 | (setf |
215 | (slot-value object 'location) |
216 | (%gobject-newv (type-number-of object) (length args) params)) |
217 | (loop |
218 | repeat (length args) |
219 | as tmp = params then (sap+ tmp (+ string-size +gvalue-size+)) |
220 | do (funcall string-destroy tmp) |
221 | (gvalue-unset (sap+ tmp string-size))) |
222 | (deallocate-memory params))) |
8755b1a5 |
223 | (setf |
224 | (slot-value object 'location) |
040579dd |
225 | (%gobject-new (type-number-of object)))))) |
8755b1a5 |
226 | |
4d83a8a6 |
227 | (apply #'call-next-method object initargs)) |
228 | |
229 | |
1dbf4216 |
230 | (defmethod instance-finalizer ((instance gobject)) |
231 | (let ((location (proxy-location instance))) |
232 | #'(lambda () |
233 | (remove-cached-instance location) |
1dbf4216 |
234 | (%object-unref location)))) |
235 | |
9adccb27 |
236 | |
d4b21b08 |
237 | (defbinding (%gobject-new "g_object_new") () pointer |
a9044181 |
238 | (type type-number) |
239 | (nil null)) |
560af5c5 |
240 | |
9adccb27 |
241 | (defbinding (%gobject-newv "g_object_newv") () pointer |
4d83a8a6 |
242 | (type type-number) |
243 | (n-parameters unsigned-int) |
9adccb27 |
244 | (params pointer)) |
de8516ca |
245 | |
246 | |
d4b21b08 |
247 | |
323d4265 |
248 | ;;;; Property stuff |
560af5c5 |
249 | |
26b133ed |
250 | (defbinding %object-set-property () nil |
c8c48a4c |
251 | (object gobject) |
252 | (name string) |
253 | (value gvalue)) |
86d9d6ab |
254 | |
26b133ed |
255 | (defbinding %object-get-property () nil |
c8c48a4c |
256 | (object gobject) |
257 | (name string) |
a9044181 |
258 | (value gvalue)) |
86d9d6ab |
259 | |
26b133ed |
260 | (defbinding %object-notify () nil |
c8c48a4c |
261 | (object gobject) |
262 | (name string)) |
86d9d6ab |
263 | |
26b133ed |
264 | (defbinding object-freeze-notify () nil |
a9044181 |
265 | (object gobject)) |
86d9d6ab |
266 | |
26b133ed |
267 | (defbinding object-thaw-notify () nil |
a9044181 |
268 | (object gobject)) |
86d9d6ab |
269 | |
a00ba56a |
270 | |
271 | ;;;; User data |
272 | |
26b133ed |
273 | (defbinding %object-set-qdata-full () nil |
86d9d6ab |
274 | (object gobject) |
275 | (id quark) |
276 | (data unsigned-long) |
277 | (destroy-marshal pointer)) |
278 | |
73572c12 |
279 | (defcallback user-data-destroy-func (nil (id unsigned-int)) |
280 | (destroy-user-data id)) |
281 | |
282 | (export 'user-data-destroy-func) |
283 | |
174e8a5c |
284 | (defun (setf user-data) (data object key) |
a00ba56a |
285 | (%object-set-qdata-full object (quark-intern key) |
73572c12 |
286 | (register-user-data data) (callback user-data-destroy-func)) |
86d9d6ab |
287 | data) |
288 | |
a00ba56a |
289 | ;; deprecated |
174e8a5c |
290 | (defun (setf object-data) (data object key &key (test #'eq)) |
291 | (assert (eq test #'eq)) |
292 | (setf (user-data object key) data)) |
293 | |
26b133ed |
294 | (defbinding %object-get-qdata () unsigned-long |
86d9d6ab |
295 | (object gobject) |
296 | (id quark)) |
297 | |
174e8a5c |
298 | (defun user-data (object key) |
a00ba56a |
299 | (find-user-data (%object-get-qdata object (quark-intern key)))) |
174e8a5c |
300 | |
a00ba56a |
301 | ;; deprecated |
86d9d6ab |
302 | (defun object-data (object key &key (test #'eq)) |
174e8a5c |
303 | (assert (eq test #'eq)) |
304 | (user-data object key)) |
305 | |
306 | (defun user-data-p (object key) |
a00ba56a |
307 | (user-data-exists-p (%object-get-qdata object (quark-intern key)))) |
308 | |
309 | (defbinding %object-steal-qdata () unsigned-long |
310 | (object gobject) |
311 | (id quark)) |
312 | |
313 | (defun unset-user-data (object key) |
314 | (destroy-user-data (%object-steal-qdata object (quark-intern key)))) |
86d9d6ab |
315 | |
316 | |
d4b21b08 |
317 | ;;;; |
318 | |
323d4265 |
319 | (defbinding %object-class-list-properties () pointer |
d4b21b08 |
320 | (class pointer) |
321 | (n-properties unsigned-int :out)) |
322 | |
9c03a07c |
323 | |
324 | (defun %map-params (params length type inherited-p) |
325 | (if inherited-p |
9adccb27 |
326 | (map-c-vector 'list #'identity params 'param length) |
9c03a07c |
327 | (let ((properties ())) |
9adccb27 |
328 | (map-c-vector 'list |
9c03a07c |
329 | #'(lambda (param) |
330 | (when (eql (param-owner-type param) type) |
331 | (push param properties))) |
332 | params 'param length) |
333 | (nreverse properties)))) |
334 | |
335 | (defun query-object-class-properties (type &optional inherited-p) |
336 | (let* ((type-number (find-type-number type)) |
337 | (class (type-class-ref type-number))) |
338 | (unwind-protect |
339 | (multiple-value-bind (array length) |
340 | (%object-class-list-properties class) |
21299acf |
341 | (unless (null-pointer-p array) |
342 | (unwind-protect |
343 | (%map-params array length type-number inherited-p) |
344 | (deallocate-memory array)))) |
9c03a07c |
345 | ; (type-class-unref type-number) |
346 | ))) |
d4b21b08 |
347 | |
348 | |
349 | (defun default-slot-name (name) |
350 | (intern (substitute #\- #\_ (string-upcase (string-upcase name))))) |
351 | |
352 | (defun default-slot-accessor (class-name slot-name type) |
353 | (intern |
354 | (format |
355 | nil "~A-~A~A" class-name slot-name |
4d83a8a6 |
356 | (if (eq type 'boolean) "-P" "")))) |
d4b21b08 |
357 | |
323d4265 |
358 | |
646466b0 |
359 | (defun slot-definition-from-property (class property &optional slot-name args) |
9c03a07c |
360 | (with-slots (name flags value-type documentation) property |
646466b0 |
361 | (let* ((slot-name (or slot-name (default-slot-name name))) |
62f12808 |
362 | (slot-type (or (getf args :type) (type-from-number value-type) 'pointer)) |
9c03a07c |
363 | (accessor (default-slot-accessor class slot-name slot-type))) |
364 | |
365 | `(,slot-name |
366 | :allocation :property :pname ,name |
eeda1c2d |
367 | |
eeda1c2d |
368 | ,@(cond |
ae37d096 |
369 | ((find :unbound args) (list :unbound (getf args :unbound)))) |
9c03a07c |
370 | |
371 | ;; accessors |
372 | ,@(cond |
373 | ((and |
374 | (member :writable flags) (member :readable flags) |
375 | (not (member :construct-only flags))) |
376 | (list :accessor accessor)) |
377 | ((and (member :writable flags) (not (member :construct-only flags))) |
378 | (list :writer `(setf ,accessor))) |
379 | ((member :readable flags) |
380 | (list :reader accessor))) |
381 | |
382 | ;; readable/writable/construct |
383 | ,@(when (or (not (member :writable flags)) |
384 | (member :construct-only flags)) |
385 | '(:writable nil)) |
386 | ,@(when (not (member :readable flags)) |
387 | '(:readable nil)) |
388 | ,@(when (or (member :construct flags) |
389 | (member :construct-only flags)) |
390 | '(:construct t)) |
391 | |
392 | ;; initargs |
393 | ,@(when (or (member :construct flags) |
394 | (member :construct-only flags) |
395 | (member :writable flags)) |
396 | (list :initarg (intern (string slot-name) "KEYWORD"))) |
56870989 |
397 | ,@(cond |
398 | ((find :initarg args) (list :initarg (getf args :initarg)))) |
9c03a07c |
399 | |
400 | :type ,slot-type |
401 | :documentation ,documentation)))) |
402 | |
403 | |
404 | (defun slot-definitions (class properties slots) |
405 | (loop |
9c03a07c |
406 | for property in properties |
eeda1c2d |
407 | as slot = (or |
408 | (find (param-name property) slots |
409 | :key #'(lambda (slot) (getf (rest slot) :pname)) |
410 | :test #'string=) |
411 | (find (param-name property) slots |
412 | :key #'first :test #'string-equal)) |
413 | do (cond |
414 | ((not slot) |
415 | (push (slot-definition-from-property class property) slots)) |
416 | ((getf (rest slot) :merge) |
417 | (setf |
418 | (rest slot) |
646466b0 |
419 | (rest (slot-definition-from-property class property (first slot) (rest slot))))))) |
9c03a07c |
420 | (delete-if #'(lambda (slot) (getf (rest slot) :ignore)) slots)) |
421 | |
422 | |
62f12808 |
423 | (defun expand-gobject-type (type forward-p options &optional (metaclass 'gobject-class)) |
9c03a07c |
424 | (let ((supers (cons (supertype type) (implements type))) |
425 | (class (type-from-number type)) |
426 | (slots (getf options :slots))) |
427 | `(defclass ,class ,supers |
62f12808 |
428 | ,(unless forward-p |
429 | (slot-definitions class (query-object-class-properties type) slots)) |
9c03a07c |
430 | (:metaclass ,metaclass) |
431 | (:alien-name ,(find-type-name type))))) |
323d4265 |
432 | |
62f12808 |
433 | (defun gobject-dependencies (type) |
21299acf |
434 | (delete-duplicates |
435 | (cons |
436 | (supertype type) |
437 | (append |
438 | (type-interfaces type) |
439 | (mapcar #'param-value-type (query-object-class-properties type)))))) |
d4b21b08 |
440 | |
62f12808 |
441 | |
442 | (register-derivable-type 'gobject "GObject" 'expand-gobject-type 'gobject-dependencies) |
ae37d096 |
443 | |
444 | |
445 | ;;; Pseudo type for gobject instances which have their reference count |
446 | ;;; increased by the returning function |
447 | |
448 | (defmethod alien-type ((type (eql 'referenced)) &rest args) |
449 | (declare (ignore type args)) |
450 | (alien-type 'gobject)) |
451 | |
452 | (defmethod from-alien-form (form (type (eql 'referenced)) &rest args) |
453 | (declare (ignore type)) |
454 | (destructuring-bind (type) args |
455 | (if (subtypep type 'gobject) |
456 | (let ((instance (make-symbol "INSTANCE"))) |
457 | `(let ((,instance ,(from-alien-form form type))) |
458 | (when ,instance |
459 | (%object-unref (proxy-location ,instance))) |
460 | ,instance)) |
461 | (error "~A is not a subclass of GOBJECT" type)))) |
462 | |
463 | (export 'referenced) |