X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.foreign-gboxed.lisp;h=5b201bea67a5b53776571e8aaa635ac96cb25e9c;hb=8a11479e1b671d256c68cf71d7e4e22971498c8b;hp=00aff151b47f2a0d827f31f65edf8ba3b6b78897;hpb=c516e3bb9ea37479ffd9005845844b7be596e295;p=cl-gtk2.git diff --git a/glib/gobject.foreign-gboxed.lisp b/glib/gobject.foreign-gboxed.lisp index 00aff15..5b201be 100644 --- a/glib/gobject.foreign-gboxed.lisp +++ b/glib/gobject.foreign-gboxed.lisp @@ -85,8 +85,15 @@ (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)) @@ -99,7 +106,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 +122,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 +148,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,35 +176,37 @@ (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)) (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)) @@ -206,38 +215,46 @@ (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)) - ;;This actually turned out to be wrong - #+(or) - (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)) - (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*)) + (with-recursive-lock-held (*g-boxed-gc-lock*) + (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*) + (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) - (let ((address (pointer-address (pointer object)))) - (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 to 1~%" (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))))))) + (with-recursive-lock-held (*g-boxed-gc-lock*) + (let ((address (pointer-address (pointer object)))) + (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*) + (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)) @@ -252,7 +269,7 @@ (owner :reader g-boxed-ref-owner :initarg :owner :initform nil)) (:actual-type :pointer)) -(define-parse-method g-boxed-ref (class-name &key (owner :lisp)) +(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 :owner owner)) @@ -264,22 +281,32 @@ (defun convert-g-boxed-ref-from-pointer (pointer name type) (unless (null-pointer-p pointer) - (or (gethash (pointer-address pointer) *known-boxed-refs*) - (prog1 (make-instance name :pointer pointer) - (setf (gethash (pointer-address pointer) *boxed-ref-owner*) (g-boxed-ref-owner type)))))) + (with-recursive-lock-held (*g-boxed-gc-lock*) + (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)) - (convert-g-boxed-ref-from-pointer value (g-boxed-ref-class-name type) 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)) + (destructuring-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)))))))) @@ -320,14 +347,24 @@ 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)) @@ -338,5 +375,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 (make-instance 'g-boxed-ref-type :class-name 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