(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)))
(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))
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)))
,@(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))
(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)))
(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))
(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))
(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))
(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))))))))
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)
(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
- ((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
projects / cl-gtk2.git / blobdiff