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