(real-parse-g-boxed pointer object)
object))
-(defun g-boxed->cstruct (object)
- (let ((pointer (foreign-alloc (type-of 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))
(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))
(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))))))))
(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))
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)
- (declare (ignore gvalue value))
- (error "Can not set GBoxed!"))
+ (if value
+ (progn
+ (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)
(let* ((g-type (gvalue-type gvalue))
(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