3 (defun ensure-list (thing)
4 (if (listp thing) thing (list thing)))
6 (defun slot->cstruct-slot (slot)
7 (destructuring-bind (name type &key &allow-other-keys) slot
10 (defun slot->slot-name (slot)
11 (destructuring-bind (name type &key &allow-other-keys) slot
12 (declare (ignore type))
15 (defun cstruct-definition (name slots)
16 `(defcstruct ,name ,@(mapcar #'slot->cstruct-slot slots)))
18 (defun maybe-unlist (thing)
19 (if (or (not (listp thing)) (cdr thing))
23 (defun slot->struct-slot (slot)
24 (destructuring-bind (name type &key initform &allow-other-keys) slot
25 (declare (ignore type))
26 (maybe-unlist `(,name ,@(when initform (list initform))))))
28 (defun struct-definition (name superclass slots)
29 `(defstruct ,@(if superclass
30 (list `(,name (:include ,superclass)))
32 ,@(mapcar #'slot->struct-slot slots)))
34 (define-foreign-type g-boxed-pointer-type ()
35 ((name :accessor g-boxed-pointer-type-name :initarg :name)
36 (outp :accessor g-boxed-pointer-type-outp :initarg :outp)))
38 (define-parse-method g-boxed-ptr (name &optional (type :in))
39 (make-instance 'g-boxed-pointer-type :name name :actual-type :pointer :outp (ecase type
43 (defmethod translate-from-foreign (value (type g-boxed-pointer-type))
44 (unless (null-pointer-p value)
45 (parse-g-boxed value (g-boxed-pointer-type-name type))))
47 (defmethod translate-to-foreign (value (type g-boxed-pointer-type))
48 (let ((ptr (foreign-alloc (boxed-c-structure-name (g-boxed-pointer-type-name type)))))
49 (real-unparse-g-boxed ptr value)
52 (defmethod free-translated-object (ptr (type g-boxed-pointer-type) param)
53 (when (g-boxed-pointer-type-outp type)
54 (let ((original-object param)
55 (new-real-name (g-boxed-real-name ptr (g-boxed-pointer-type-name type))))
56 (if (eq new-real-name (type-of original-object))
57 (real-parse-g-boxed ptr original-object)
58 (error "Type has changed!"))))
61 (defmethod expand-to-foreign-dyn (value var body (type g-boxed-pointer-type))
62 (let ((value-var (gensym)))
63 `(with-foreign-object (,var ',(boxed-c-structure-name (g-boxed-pointer-type-name type)))
64 (let ((,value-var ,value))
65 (real-unparse-g-boxed ,var ,value-var)
67 ,@(when (g-boxed-pointer-type-outp type)
68 (list `(let ((new-real-name (g-boxed-real-name ,var ',(g-boxed-pointer-type-name type))))
69 (if (eq new-real-name (type-of ,value-var))
70 (real-parse-g-boxed ,var ,value-var)
71 (error "Type has changed from ~A to ~A" (type-of ,value-var) new-real-name)))))))))
73 (define-foreign-type g-boxed-inline-type ()
74 ((name :accessor g-boxed-inline-type :initarg :name)))
76 (define-parse-method g-boxed-inline (name)
77 (make-instance 'g-boxed-inline-type :name name :actual-type name))
79 (defgeneric real-parse-g-boxed (pointer object))
80 (defgeneric real-unparse-g-boxed (pointer object))
82 (defun parse-g-boxed (pointer name)
83 (let* ((real-name (g-boxed-real-name pointer name))
84 (object (make-instance real-name)))
85 (real-parse-g-boxed pointer object)
88 (defun g-boxed->cstruct (object)
89 (let ((pointer (foreign-alloc (type-of object))))
90 (real-unparse-g-boxed pointer object)
93 (defun g-boxed-real-name (pointer name)
95 for (sub-name slot values) in (get name 'boxed-dispatch)
96 do (debugf "Checking ~A ~A ~A against ~A.~A = ~A~%" sub-name slot values name slot (foreign-slot-value pointer name slot))
97 when (member (foreign-slot-value pointer name slot) values :test 'equalp)
98 return (g-boxed-real-name pointer sub-name))
101 (defun slot->slot-parser (class-name pointer-var slot)
102 (bind (((slot-name slot-type &key parser &allow-other-keys) slot))
105 `(setf ,slot-name (funcall ,parser ',class-name ,pointer-var)))
106 ((and (listp slot-type) (eq 'g-boxed-inline (first slot-type)))
107 `(setf ,slot-name (parse-g-boxed (foreign-slot-pointer ,pointer-var ',class-name ',slot-name) ',(second slot-type))))
109 `(setf ,slot-name (foreign-slot-value ,pointer-var ',class-name ',slot-name))))))
111 (defun parse-method-definition (name slots)
112 (let ((slot-names (mapcar #'slot->slot-name slots)))
113 `(defmethod real-parse-g-boxed (pointer (object ,name))
114 (with-slots (,@slot-names) object
115 ,@(mapcar (lambda (slot) (slot->slot-parser name 'pointer slot)) slots)))))
117 (defun slot->slot-unparser (class-name pointer-var slot object)
118 (bind (((slot-name slot-type &key unparser &allow-other-keys) slot))
121 `(funcall ,unparser ',class-name ,pointer-var ,object))
122 ((and (listp slot-type) (eq 'g-boxed-inline (first slot-type)))
123 `(real-unparse-g-boxed (foreign-slot-pointer ,pointer-var ',class-name ',slot-name) ,slot-name))
125 `(setf (foreign-slot-value ,pointer-var ',class-name ',slot-name) ,slot-name)))))
127 (defun unparse-method-definition (name slots)
128 (let ((slot-names (mapcar #'slot->slot-name slots)))
129 `(defmethod real-unparse-g-boxed (pointer (object ,name))
130 (with-slots (,@slot-names) object
131 ,@(mapcar (lambda (slot) (slot->slot-unparser name 'pointer slot 'object)) slots)))))
133 (defun slot->export-accessor (class-name slot)
134 (destructuring-bind (slot-name slot-type &key &allow-other-keys) slot
135 (declare (ignore slot-type))
136 (let ((accessor-name (intern (format nil "~A-~A" (symbol-name class-name) (symbol-name slot-name))
137 (symbol-package class-name))))
138 `(export ',accessor-name (symbol-package ',accessor-name)))))
140 (defun struct-constructor-name (name)
141 (intern (format nil "MAKE-~A" (symbol-name name)) (symbol-package name)))
143 (defun get-g-boxed-direct-subclasses (name)
144 (mapcar (lambda (spec) (bind (((name slot values) spec))
145 (declare (ignore slot values))
147 (get name 'boxed-dispatch)))
149 (defun map-append (f &rest lists)
150 (reduce #'append (apply #'mapcar f lists)))
152 (defun get-g-boxed-all-subclasses (name)
154 (map-append #'get-g-boxed-all-subclasses (get-g-boxed-direct-subclasses name))))
156 (defun get-g-boxed-completed-c-definition (name union-name)
157 `(defcunion ,union-name
158 ,@(mapcar (lambda (sub-name)
159 `(,sub-name ,sub-name))
160 (get-g-boxed-all-subclasses name))))
162 (defun g-boxed-root (name)
163 (if (get name 'superclass)
164 (g-boxed-root (get name 'superclass))
167 (defmacro update-g-boxed-root-c-class (name)
168 (when (get name 'c-name)
169 (get-g-boxed-completed-c-definition (g-boxed-root name) (get name 'c-name))))
171 (defmacro define-g-boxed-class (g-name-and-c-name name (&optional superclass-and-dispatch (export t)) &body slots)
172 (bind (((&optional g-name c-name) (ensure-list g-name-and-c-name))
173 ((&optional superclass dispatch-slot dispatch-values) superclass-and-dispatch)
174 (superclass-slots (get superclass 'boxed-combined-slots))
175 (combined-slots (append superclass-slots slots)))
176 (setf c-name (or c-name (gensym "C-UNION-")))
177 `(progn ,(cstruct-definition name combined-slots)
178 ,(struct-definition name superclass slots)
179 ,(parse-method-definition name combined-slots)
180 ,(unparse-method-definition name combined-slots)
181 (eval-when (:load-toplevel :compile-toplevel :execute)
182 (setf (get ',name 'boxed-slots) ',slots
183 (get ',name 'boxed-combined-slots) ',combined-slots
184 (get ',name 'superclass) ',superclass
185 (get ',name 'c-name) (or (get ',name 'c-name) ',c-name))
187 (list `(pushnew '(,name ,dispatch-slot ,(ensure-list dispatch-values)) (get ',superclass 'boxed-dispatch) :test 'equalp))))
188 (update-g-boxed-root-c-class ,name)
190 (list `(register-boxed-type ,g-name ',name)))
192 (append (list `(export ',name (symbol-package ',name))
193 `(export ',(struct-constructor-name name) (symbol-package ',(struct-constructor-name name))))
194 (mapcar (lambda (slot) (slot->export-accessor name slot)) slots))))))
196 (defun boxed-c-structure-name (name)
197 (get (g-boxed-root name) 'c-name))
199 (defclass g-boxed-ref () ((pointer :accessor pointer :initarg :pointer)))
201 (defvar *known-boxed-refs* (tg:make-weak-hash-table :test 'equal :weakness :value))
202 (defvar *boxed-ref-count* (make-hash-table :test 'equal))
203 (defvar *boxed-ref-owner* (make-hash-table :test 'equal))
205 (defun boxed-ref-free-function (name)
206 (or (get name 'free-function)
207 (error "g-boxed-ref class ~A has no free-function" name)))
209 (defun dispose-boxed-ref (type pointer)
210 (debugf "disposing g-boxed-ref ~A~%" pointer)
211 (unless (gethash (pointer-address pointer) *boxed-ref-count*)
212 (error "g-boxed-ref ~A is already disposed from lisp-side" pointer))
213 ;;This actually turned out to be wrong
215 (unless (zerop (gethash (pointer-address pointer) *boxed-ref-count*))
216 (error "g-boxed-ref ~A is being disposed too early, it has still ~A references from lisp-side"
217 (pointer-address pointer)
218 (gethash (pointer-address pointer) *boxed-ref-count*)))
219 (aif (gethash (pointer-address pointer) *known-boxed-refs*)
220 (tg:cancel-finalization it))
221 (when (eq :lisp (gethash (pointer-address pointer) *boxed-ref-owner*))
222 (funcall (boxed-ref-free-function type) pointer))
223 (remhash (pointer-address pointer) *known-boxed-refs*)
224 (remhash (pointer-address pointer) *boxed-ref-count*)
225 (remhash (pointer-address pointer) *boxed-ref-owner*))
227 (defmethod initialize-instance :after ((object g-boxed-ref) &key)
228 (let ((address (pointer-address (pointer object))))
229 (setf (gethash address *known-boxed-refs*) object)
230 (setf (gethash address *boxed-ref-count*) 1)
231 (setf (gethash address *boxed-ref-owner*) :foreign))
232 (debugf "setting g-boxed-ref-count of ~A to 1~%" (pointer object))
233 (let ((p (pointer object))
234 (type (type-of object))
235 (s (format nil "~A" object)))
236 (tg:finalize object (lambda ()
238 (dispose-boxed-ref type p)
239 (error (e) (format t "Error ~A for ~A~%" e s)))))))
241 (defmethod release ((object g-boxed-ref))
242 (debugf "releasing g-boxed-ref ~A~%" (pointer object))
243 (unless (gethash (pointer-address (pointer object)) *boxed-ref-count*)
244 (error "g-boxed-ref ~A is already disposed from lisp-side" (pointer object)))
245 (decf (gethash (pointer-address (pointer object)) *boxed-ref-count*))
246 (when (zerop (gethash (pointer-address (pointer object)) *boxed-ref-count*))
247 (dispose-boxed-ref (type-of object) (pointer object))))
249 (define-foreign-type g-boxed-ref-type ()
250 ((class-name :reader g-boxed-ref-class-name :initarg :class-name)
251 (owner :reader g-boxed-ref-owner :initarg :owner :initform nil))
252 (:actual-type :pointer))
254 (define-parse-method g-boxed-ref (class-name &key (owner :lisp))
255 (unless (get class-name 'is-g-boxed-ref)
256 (error "~A is not a subtype of G-BOXED-REF (~A: ~S)" class-name class-name (symbol-plist class-name)))
257 (make-instance 'g-boxed-ref-type :class-name class-name :owner owner))
259 (defmethod translate-to-foreign (value (type g-boxed-ref-type))
264 (defun convert-g-boxed-ref-from-pointer (pointer name type)
265 (unless (null-pointer-p pointer)
266 (or (gethash (pointer-address pointer) *known-boxed-refs*)
267 (prog1 (make-instance name :pointer pointer)
268 (setf (gethash (pointer-address pointer) *boxed-ref-owner*) (g-boxed-ref-owner type))))))
270 (defmethod translate-from-foreign (value (type g-boxed-ref-type))
271 (convert-g-boxed-ref-from-pointer value (g-boxed-ref-class-name type) type))
273 (defun g-boxed-ref-slot->methods (class slot)
274 (bind (((slot-name &key reader writer type) slot))
275 `(progn ,@(when reader
276 (list `(defmethod ,slot-name ((object ,class))
277 ,(if (stringp reader)
278 `(foreign-funcall ,reader :pointer (pointer object) ,type)
279 `(,reader object)))))
281 (list `(defmethod (setf ,slot-name) (new-value (object ,class))
282 ,(if (stringp writer)
283 `(foreign-funcall ,writer :pointer (pointer object) ,type new-value)
284 `(,writer new-value object))))))))
286 (defmacro define-g-boxed-ref (gobject-name name &rest properties)
287 (let ((free-fn (second (find :free-function properties :key 'first)))
288 (alloc-fn (second (find :alloc-function properties :key 'first)))
289 (slots (rest (find :slots properties :key 'first))))
290 (unless (and free-fn alloc-fn) (error "All of :free-function, :alloc-function must be specified"))
291 `(progn (defclass ,name (g-boxed-ref) ())
292 (defmethod initialize-instance :before ((object ,name) &key pointer)
293 (unless (or pointer (slot-boundp object 'pointer))
294 (setf (pointer object) (,alloc-fn)
295 (gethash (pointer-address pointer) *boxed-ref-owner*) :lisp)))
296 (setf (get ',name 'free-function) ',free-fn)
297 (eval-when (:compile-toplevel :load-toplevel :execute)
298 (setf (get ',name 'is-g-boxed-ref) t))
299 ,@(mapcar (lambda (slot)
300 (g-boxed-ref-slot->methods name slot))
302 (register-boxed-type ,gobject-name ',name))))
304 (define-foreign-type fixed-array ()
305 ((element-type :reader fixed-array-element-type :initarg :element-type :initform (error "Element type must be specified"))
306 (array-size :reader fixed-array-array-size :initarg :array-size :initform (error "Array size must be specified")))
307 (:actual-type :pointer))
309 (define-parse-method fixed-array (element-type array-size)
310 (make-instance 'fixed-array :element-type element-type :array-size array-size))
312 (defmethod translate-from-foreign (ptr (type fixed-array))
313 (when (not (null-pointer-p ptr))
314 (let ((result (make-array (fixed-array-array-size type)))
315 (el-type (fixed-array-element-type type)))
317 for i from 0 below (fixed-array-array-size type)
318 do (setf (aref result i) (mem-aref ptr el-type i)))
321 (defvar *registered-boxed-types* (make-hash-table :test 'equal))
322 (defun register-boxed-type (name type)
323 (setf (gethash name *registered-boxed-types*) type))
324 (defun get-registered-boxed-type (name)
325 (gethash name *registered-boxed-types*))
327 (defun set-gvalue-boxed (gvalue value)
328 (declare (ignore gvalue value))
329 (error "Can not set GBoxed!"))
331 (defun parse-gvalue-boxed (gvalue)
332 (let* ((g-type (gvalue-type gvalue))
333 (type-name (g-type-name g-type))
334 (boxed-type (get-registered-boxed-type type-name)))
336 (warn t "Type ~A is a not registered GBoxed~%" type-name)
337 (return-from parse-gvalue-boxed nil))
338 (unless (null-pointer-p (g-value-get-boxed gvalue))
340 ((subtypep boxed-type 'g-boxed-ref) (convert-g-boxed-ref-from-pointer (g-value-get-boxed gvalue) boxed-type (make-instance 'g-boxed-ref-type :class-name boxed-type)))
341 (t (parse-g-boxed (g-value-get-boxed gvalue) boxed-type))))))