X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.foreign-gboxed.lisp;h=a6525c357ff2a88a300857a208f49126ccca7098;hb=e59a66b7c41298df0235dacd2caa360c14865c81;hp=712e3e02d5fd8a61e923cdf5fb5d8c5ac7065184;hpb=0d03b82a77743d2ea5ef69bea08735fa12857d92;p=cl-gtk2.git diff --git a/glib/gobject.foreign-gboxed.lisp b/glib/gobject.foreign-gboxed.lisp index 712e3e0..a6525c3 100644 --- a/glib/gobject.foreign-gboxed.lisp +++ b/glib/gobject.foreign-gboxed.lisp @@ -198,35 +198,53 @@ (defclass g-boxed-ref () ((pointer :accessor pointer :initarg :pointer))) +(defvar *g-boxed-gc-lock* (make-recursive-lock "g-boxed-gc-lock")) (defvar *known-boxed-refs* (tg:make-weak-hash-table :test 'equal :weakness :value)) (defvar *boxed-ref-count* (make-hash-table :test 'equal)) +(defvar *boxed-ref-owner* (make-hash-table :test 'equal)) (defun boxed-ref-free-function (name) (or (get name 'free-function) (error "g-boxed-ref class ~A has no free-function" name))) +(defun disown-boxed-ref (object) + (setf (gethash (pointer-address (pointer object)) *boxed-ref-owner*) :foreign)) + (defun dispose-boxed-ref (type pointer) (debugf "disposing g-boxed-ref ~A~%" pointer) + (unless (gethash (pointer-address pointer) *boxed-ref-count*) (error "g-boxed-ref ~A is already disposed from lisp-side" pointer)) - (unless (zerop (gethash (pointer-address pointer) *boxed-ref-count*)) - (error "g-boxed-ref ~A is being disposed too early, it has still ~A references from lisp-side" - (pointer-address pointer) - (gethash (pointer-address pointer) *boxed-ref-count*))) - (aif (gethash (pointer-address pointer) *known-boxed-refs*) - (tg:cancel-finalization it)) - (funcall (boxed-ref-free-function type) pointer) - (remhash (pointer-address pointer) *known-boxed-refs*) - (remhash (pointer-address pointer) *boxed-ref-count*)) + (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)) + (when (eq :lisp (gethash (pointer-address pointer) *boxed-ref-owner*)) + (funcall (boxed-ref-free-function type) pointer)) + (remhash (pointer-address pointer) *known-boxed-refs*) + (remhash (pointer-address pointer) *boxed-ref-count*) + (remhash (pointer-address pointer) *boxed-ref-owner*) + (debugf "Disposed of g-boxed-ref ~A (object ~A)~%" + pointer + (gethash (pointer-address pointer) *known-boxed-refs*)))) (defmethod initialize-instance :after ((object g-boxed-ref) &key) - (setf (gethash (pointer-address (pointer object)) *known-boxed-refs*) object) - (setf (gethash (pointer-address (pointer object)) *boxed-ref-count*) 1) - (debugf "setting g-boxed-ref-count of ~A to 1~%" (pointer object)) - (let ((p (pointer object)) - (type (type-of object))) - (tg:finalize object (lambda () - (dispose-boxed-ref type p))))) + (with-recursive-lock-held (*g-boxed-gc-lock*) + (let ((address (pointer-address (pointer object)))) + (awhen (gethash address *known-boxed-refs*) + (tg:cancel-finalization it)) + (setf (gethash address *known-boxed-refs*) object) + (setf (gethash address *boxed-ref-count*) 1) + (setf (gethash address *boxed-ref-owner*) + (gethash address *boxed-ref-owner* :foreign))) + (debugf "setting g-boxed-ref-count of ~A (for ptr ~A) to 1~%" object (pointer object)) + (let ((p (pointer object)) + (type (type-of object)) + (s (format nil "~A" object))) + (tg:finalize object (lambda () + (handler-case + (dispose-boxed-ref type p) + (error (e) (format t "Error ~A for ~A~%" e s)))))))) (defmethod release ((object g-boxed-ref)) (debugf "releasing g-boxed-ref ~A~%" (pointer object)) @@ -237,36 +255,48 @@ (dispose-boxed-ref (type-of object) (pointer object)))) (define-foreign-type g-boxed-ref-type () - ((class-name :reader g-boxed-ref-class-name :initarg :class-name)) + ((class-name :reader g-boxed-ref-class-name :initarg :class-name) + (owner :reader g-boxed-ref-owner :initarg :owner :initform nil)) (:actual-type :pointer)) -(define-parse-method g-boxed-ref (class-name) +(define-parse-method g-boxed-ref (class-name &key (owner :foreign)) (unless (get class-name 'is-g-boxed-ref) (error "~A is not a subtype of G-BOXED-REF (~A: ~S)" class-name class-name (symbol-plist class-name))) - (make-instance 'g-boxed-ref-type :class-name class-name)) + (make-instance 'g-boxed-ref-type :class-name class-name :owner owner)) (defmethod translate-to-foreign (value (type g-boxed-ref-type)) (if value (pointer value) (null-pointer))) -(defun convert-g-boxed-ref-from-pointer (pointer name) +(defun convert-g-boxed-ref-from-pointer (pointer name type) (unless (null-pointer-p pointer) - (or (gethash (pointer-address pointer) *known-boxed-refs*) - (make-instance name :pointer 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))))) (defmethod translate-from-foreign (value (type g-boxed-ref-type)) - (convert-g-boxed-ref-from-pointer value (g-boxed-ref-class-name 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 + (prog1 + (convert-g-boxed-ref-from-pointer value (g-boxed-ref-class-name type) type) + (setf (gethash (pointer-address value) *boxed-ref-owner*) owner)))) (defun g-boxed-ref-slot->methods (class slot) - (bind (((slot-name &key reader writer type) slot)) + (bind (((slot-name &key reader writer type (accessor slot-name)) slot)) `(progn ,@(when reader - (list `(defmethod ,slot-name ((object ,class)) + (list `(defmethod ,accessor ((object ,class)) ,(if (stringp reader) `(foreign-funcall ,reader :pointer (pointer object) ,type) `(,reader object))))) ,@(when writer - (list `(defmethod (setf ,slot-name) (new-value (object ,class)) + (list `(defmethod (setf ,accessor) (new-value (object ,class)) ,(if (stringp writer) `(foreign-funcall ,writer :pointer (pointer object) ,type new-value) `(,writer new-value object)))))))) @@ -277,9 +307,10 @@ (slots (rest (find :slots properties :key 'first)))) (unless (and free-fn alloc-fn) (error "All of :free-function, :alloc-function must be specified")) `(progn (defclass ,name (g-boxed-ref) ()) - (defmethod initialize-instance ((object ,name) &key) - (unless (slot-boundp object 'pointer) - (setf (pointer object) (,alloc-fn)))) + (defmethod initialize-instance :before ((object ,name) &key pointer) + (unless (or pointer (slot-boundp object 'pointer)) + (setf (pointer object) (,alloc-fn) + (gethash (pointer-address (pointer object)) *boxed-ref-owner*) :lisp))) (setf (get ',name 'free-function) ',free-fn) (eval-when (:compile-toplevel :load-toplevel :execute) (setf (get ',name 'is-g-boxed-ref) t)) @@ -312,8 +343,11 @@ (gethash name *registered-boxed-types*)) (defun set-gvalue-boxed (gvalue value) - (declare (ignore gvalue value)) - (error "Can not set GBoxed!")) + (if value + (progn + (unless (typep value 'g-boxed-ref) (error "Can only set g-boxed-ref!")) + (g-value-set-boxed gvalue (pointer value))) + (g-value-set-boxed gvalue (null-pointer)))) (defun parse-gvalue-boxed (gvalue) (let* ((g-type (gvalue-type gvalue)) @@ -324,5 +358,5 @@ (return-from parse-gvalue-boxed nil)) (unless (null-pointer-p (g-value-get-boxed gvalue)) (cond - ((subtypep boxed-type 'g-boxed-ref) (convert-g-boxed-ref-from-pointer (g-value-get-boxed gvalue) boxed-type)) + ((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 :owner :foreign))) (t (parse-g-boxed (g-value-get-boxed gvalue) boxed-type)))))) \ No newline at end of file