X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.foreign-gboxed.lisp;h=ff6d9dae3322fb8bedd2f0b09a93dfd8aaab42e3;hb=08e589f6c584cb2a4c46f9e99547ac6c2bc75bf0;hp=a6525c357ff2a88a300857a208f49126ccca7098;hpb=ec38c3b734c56a1f0ef7ec2a7d76e02dc6e83a1e;p=cl-gtk2.git diff --git a/glib/gobject.foreign-gboxed.lisp b/glib/gobject.foreign-gboxed.lisp index a6525c3..ff6d9da 100644 --- a/glib/gobject.foreign-gboxed.lisp +++ b/glib/gobject.foreign-gboxed.lisp @@ -45,30 +45,38 @@ (parse-g-boxed value (g-boxed-pointer-type-name type)))) (defmethod translate-to-foreign (value (type g-boxed-pointer-type)) - (let ((ptr (foreign-alloc (boxed-c-structure-name (g-boxed-pointer-type-name type))))) - (real-unparse-g-boxed ptr value) - (values ptr value))) + (if value + (let ((ptr (foreign-alloc (boxed-c-structure-name (g-boxed-pointer-type-name type))))) + (real-unparse-g-boxed ptr value) + (values ptr value)) + (null-pointer))) (defmethod free-translated-object (ptr (type g-boxed-pointer-type) param) - (when (g-boxed-pointer-type-outp type) - (let ((original-object param) - (new-real-name (g-boxed-real-name ptr (g-boxed-pointer-type-name type)))) - (if (eq new-real-name (type-of original-object)) - (real-parse-g-boxed ptr original-object) - (error "Type has changed!")))) + (unless (null-pointer-p ptr) + (when (g-boxed-pointer-type-outp type) + (let ((original-object param) + (new-real-name (g-boxed-real-name ptr (g-boxed-pointer-type-name type)))) + (if (eq new-real-name (type-of original-object)) + (real-parse-g-boxed ptr original-object) + (error "Type has changed!"))))) (foreign-free ptr)) (defmethod expand-to-foreign-dyn (value var body (type g-boxed-pointer-type)) (let ((value-var (gensym))) `(with-foreign-object (,var ',(boxed-c-structure-name (g-boxed-pointer-type-name type))) (let ((,value-var ,value)) - (real-unparse-g-boxed ,var ,value-var) - ,@body - ,@(when (g-boxed-pointer-type-outp type) - (list `(let ((new-real-name (g-boxed-real-name ,var ',(g-boxed-pointer-type-name type)))) - (if (eq new-real-name (type-of ,value-var)) - (real-parse-g-boxed ,var ,value-var) - (error "Type has changed from ~A to ~A" (type-of ,value-var) new-real-name))))))))) + (when ,value-var + (real-unparse-g-boxed ,var ,value-var)) + (if (null ,value-var) + (let ((,var (null-pointer))) + ,@body) + (progn ,@body + ,@(when (g-boxed-pointer-type-outp type) + (list `(when ,value-var + (let ((new-real-name (g-boxed-real-name ,var ',(g-boxed-pointer-type-name type)))) + (if (eq new-real-name (type-of ,value-var)) + (real-parse-g-boxed ,var ,value-var) + (error "Type has changed from ~A to ~A" (type-of ,value-var) new-real-name)))))))))))) (define-foreign-type g-boxed-inline-type () ((name :accessor g-boxed-inline-type :initarg :name))) @@ -80,13 +88,21 @@ (defgeneric real-unparse-g-boxed (pointer object)) (defun parse-g-boxed (pointer name) - (let* ((real-name (g-boxed-real-name pointer name)) - (object (make-instance real-name))) - (real-parse-g-boxed pointer object) - object)) - -(defun g-boxed->cstruct (object) - (let ((pointer (foreign-alloc (type-of object)))) + (unless (null-pointer-p pointer) + (let* ((real-name (g-boxed-real-name pointer name)) + (object (make-instance real-name))) + (real-parse-g-boxed pointer object) + object))) + +(defun boxed-alloc (type alloc-type) + (ecase alloc-type + (:cffi (foreign-alloc type)) + (:boxed (let ((pointer (foreign-alloc type))) + (prog1 (g-boxed-copy (g-type-from-name (boxed-type-gname type)) pointer) + (foreign-free pointer)))))) + +(defun g-boxed->cstruct (object &key (alloc-type :cffi)) + (let ((pointer (boxed-alloc (type-of object) alloc-type))) (real-unparse-g-boxed pointer object) pointer)) @@ -99,7 +115,7 @@ name)) (defun slot->slot-parser (class-name pointer-var slot) - (bind (((slot-name slot-type &key parser &allow-other-keys) slot)) + (destructuring-bind (slot-name slot-type &key parser &allow-other-keys) slot (cond (parser `(setf ,slot-name (funcall ,parser ',class-name ,pointer-var))) @@ -115,7 +131,7 @@ ,@(mapcar (lambda (slot) (slot->slot-parser name 'pointer slot)) slots))))) (defun slot->slot-unparser (class-name pointer-var slot object) - (bind (((slot-name slot-type &key unparser &allow-other-keys) slot)) + (destructuring-bind (slot-name slot-type &key unparser &allow-other-keys) slot (cond (unparser `(funcall ,unparser ',class-name ,pointer-var ,object)) @@ -141,7 +157,7 @@ (intern (format nil "MAKE-~A" (symbol-name name)) (symbol-package name))) (defun get-g-boxed-direct-subclasses (name) - (mapcar (lambda (spec) (bind (((name slot values) spec)) + (mapcar (lambda (spec) (destructuring-bind (name slot values) spec (declare (ignore slot values)) name)) (get name 'boxed-dispatch))) @@ -169,29 +185,30 @@ (get-g-boxed-completed-c-definition (g-boxed-root name) (get name 'c-name)))) (defmacro define-g-boxed-class (g-name-and-c-name name (&optional superclass-and-dispatch (export t)) &body slots) - (bind (((&optional g-name c-name) (ensure-list g-name-and-c-name)) - ((&optional superclass dispatch-slot dispatch-values) superclass-and-dispatch) - (superclass-slots (get superclass 'boxed-combined-slots)) - (combined-slots (append superclass-slots slots))) - (setf c-name (or c-name (gensym "C-UNION-"))) - `(progn ,(cstruct-definition name combined-slots) - ,(struct-definition name superclass slots) - ,(parse-method-definition name combined-slots) - ,(unparse-method-definition name combined-slots) - (eval-when (:load-toplevel :compile-toplevel :execute) - (setf (get ',name 'boxed-slots) ',slots - (get ',name 'boxed-combined-slots) ',combined-slots - (get ',name 'superclass) ',superclass - (get ',name 'c-name) (or (get ',name 'c-name) ',c-name)) - ,@(when superclass - (list `(pushnew '(,name ,dispatch-slot ,(ensure-list dispatch-values)) (get ',superclass 'boxed-dispatch) :test 'equalp)))) - (update-g-boxed-root-c-class ,name) - ,@(when g-name - (list `(register-boxed-type ,g-name ',name))) - ,@(when export - (append (list `(export ',name (symbol-package ',name)) - `(export ',(struct-constructor-name name) (symbol-package ',(struct-constructor-name name)))) - (mapcar (lambda (slot) (slot->export-accessor name slot)) slots)))))) + (destructuring-bind (&optional g-name c-name) (ensure-list g-name-and-c-name) + (destructuring-bind (&optional superclass dispatch-slot dispatch-values) superclass-and-dispatch + (let* ((superclass-slots (get superclass 'boxed-combined-slots)) + (combined-slots (append superclass-slots slots))) + + (setf c-name (or c-name (gensym "C-UNION-"))) + `(progn ,(cstruct-definition name combined-slots) + ,(struct-definition name superclass slots) + ,(parse-method-definition name combined-slots) + ,(unparse-method-definition name combined-slots) + (eval-when (:load-toplevel :compile-toplevel :execute) + (setf (get ',name 'boxed-slots) ',slots + (get ',name 'boxed-combined-slots) ',combined-slots + (get ',name 'superclass) ',superclass + (get ',name 'c-name) (or (get ',name 'c-name) ',c-name)) + ,@(when superclass + (list `(pushnew '(,name ,dispatch-slot ,(ensure-list dispatch-values)) (get ',superclass 'boxed-dispatch) :test 'equalp)))) + (update-g-boxed-root-c-class ,name) + ,@(when g-name + (list `(register-boxed-type ,g-name ',name))) + ,@(when export + (append (list `(export ',name (symbol-package ',name)) + `(export ',(struct-constructor-name name) (symbol-package ',(struct-constructor-name name)))) + (mapcar (lambda (slot) (slot->export-accessor name slot)) slots)))))))) (defun boxed-c-structure-name (name) (get (g-boxed-root name) 'c-name)) @@ -216,9 +233,10 @@ (unless (gethash (pointer-address pointer) *boxed-ref-count*) (error "g-boxed-ref ~A is already disposed from lisp-side" pointer)) (with-recursive-lock-held (*g-boxed-gc-lock*) - (awhen (gethash (pointer-address pointer) *known-boxed-refs*) - (debugf "Removing finalization from ~A for pointer ~A~%" it pointer) - (tg:cancel-finalization it)) + (let ((object (gethash (pointer-address pointer) *known-boxed-refs*))) + (when object + (debugf "Removing finalization from ~A for pointer ~A~%" object pointer) + (tg:cancel-finalization object))) (when (eq :lisp (gethash (pointer-address pointer) *boxed-ref-owner*)) (funcall (boxed-ref-free-function type) pointer)) (remhash (pointer-address pointer) *known-boxed-refs*) @@ -231,8 +249,9 @@ (defmethod initialize-instance :after ((object g-boxed-ref) &key) (with-recursive-lock-held (*g-boxed-gc-lock*) (let ((address (pointer-address (pointer object)))) - (awhen (gethash address *known-boxed-refs*) - (tg:cancel-finalization it)) + (let ((object (gethash address *known-boxed-refs*))) + (when object + (tg:cancel-finalization object))) (setf (gethash address *known-boxed-refs*) object) (setf (gethash address *boxed-ref-count*) 1) (setf (gethash address *boxed-ref-owner*) @@ -272,15 +291,15 @@ (defun convert-g-boxed-ref-from-pointer (pointer name type) (unless (null-pointer-p pointer) (with-recursive-lock-held (*g-boxed-gc-lock*) - (or (aprog1 (gethash (pointer-address pointer) *known-boxed-refs*) - (when it (debugf "Boxed-ref for ~A is found (~A)~%" pointer it)) - (when it (incf (gethash (pointer-address pointer) *boxed-ref-count*))) - it) - (aprog1 (make-instance name :pointer pointer) - (setf (gethash (pointer-address pointer) *boxed-ref-owner*) (g-boxed-ref-owner type)) - (debugf "Boxed-ref for ~A is created (~A) with owner ~A~%" pointer it - (gethash (pointer-address pointer) *boxed-ref-owner*)) - it))))) + (or (let ((object (gethash (pointer-address pointer) *known-boxed-refs*))) + (when object (debugf "Boxed-ref for ~A is found (~A)~%" pointer object)) + (when object (incf (gethash (pointer-address pointer) *boxed-ref-count*))) + object) + (let ((object (make-instance name :pointer pointer))) + (setf (gethash (pointer-address pointer) *boxed-ref-owner*) (g-boxed-ref-owner type)) + (debugf "Boxed-ref for ~A is created (~A) with owner ~A~%" pointer object + (gethash (pointer-address pointer) *boxed-ref-owner*)) + object))))) (defmethod translate-from-foreign (value (type g-boxed-ref-type)) (let ((owner (or (gethash (pointer-address value) *boxed-ref-owner*) (g-boxed-ref-owner type)))) ;;This is needed to prevent changing ownership of already created @@ -289,7 +308,7 @@ (setf (gethash (pointer-address value) *boxed-ref-owner*) owner)))) (defun g-boxed-ref-slot->methods (class slot) - (bind (((slot-name &key reader writer type (accessor slot-name)) slot)) + (destructuring-bind (slot-name &key reader writer type (accessor slot-name)) slot `(progn ,@(when reader (list `(defmethod ,accessor ((object ,class)) ,(if (stringp reader) @@ -337,16 +356,23 @@ result))) (defvar *registered-boxed-types* (make-hash-table :test 'equal)) +(defvar *registered-boxed-names* (make-hash-table)) (defun register-boxed-type (name type) - (setf (gethash name *registered-boxed-types*) type)) + (setf (gethash name *registered-boxed-types*) type + (gethash type *registered-boxed-names*) name)) (defun get-registered-boxed-type (name) (gethash name *registered-boxed-types*)) +(defun boxed-type-gname (type) + (gethash type *registered-boxed-names*)) + (defun set-gvalue-boxed (gvalue value) (if value (progn - (unless (typep value 'g-boxed-ref) (error "Can only set g-boxed-ref!")) - (g-value-set-boxed gvalue (pointer value))) + (cond + ((typep value 'g-boxed-ref) + (g-value-set-boxed gvalue (pointer value))) + (t (g-value-take-boxed gvalue (g-boxed->cstruct value :alloc-type :boxed))))) (g-value-set-boxed gvalue (null-pointer)))) (defun parse-gvalue-boxed (gvalue) @@ -354,7 +380,7 @@ (type-name (g-type-name g-type)) (boxed-type (get-registered-boxed-type type-name))) (unless boxed-type - (warn t "Type ~A is a not registered GBoxed~%" type-name) + (warn "Type ~A is a not registered GBoxed~%" type-name) (return-from parse-gvalue-boxed nil)) (unless (null-pointer-p (g-value-get-boxed gvalue)) (cond