Mon Jun 8 11:20:54 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Make unreadable cycles garbage collectable.

--- old-smoke/src/clos.lisp 2014-09-28 09:40:55.000000000 +0200

+++ new-smoke/src/clos.lisp 2014-09-28 09:40:55.000000000 +0200

@@ -107,8 +107,16 @@

(defclass smoke-standard-object ()

- ((pointer :reader pointer :initarg :pointer

- :documentation "Pointer to the C++ object."))

+ ((pointer :reader pointer

+ :initarg :pointer

+ :documentation "Pointer to the C++ object.")

+ ;; We can not have a global table of objects owned by C++,

+ ;; since then they would be alway reacable from Lisp and thus

+ ;; cycles would never be garbage collected.

+ (owned-objects :accessor owned-objects

+ :initform nil

+ :type list

+ :documentation "Objecsts owned by the C++ instance."))

(:documentation "The standard superclass for Smoke classes."))

(defmethod print-object ((object smoke-standard-object) stream)

@@ -256,7 +264,6 @@

(let ((object (get-object object-pointer)))

(when object

(cancel-finalization object)

- (remove-wrapper-object object)

(remove-object object-pointer)

(setf (slot-value object 'pointer) (null-pointer)))))

@@ -282,7 +289,7 @@

(funcall (conversion-function-name rank)

argument))))

-(defun put-returnvalue (stack value type)

+(defun put-returnvalue (stack value type object)

(unless (void-p type)

(let ((stack (make-call-stack stack)))

(setf (top stack) (pointer stack))

@@ -294,7 +301,7 @@

(push-smoke-stack stack converted-value (type-id type))

(when (stack-p type) ;; Pass by value => smoke deletes the object.

(cancel-finalization converted-value)

- (disown-object value))))))

+ (transfer-ownership-to value object))))))

(defun get-gf-for-method (smoke-method)

(declare (smoke-method smoke-method)

@@ -332,7 +339,8 @@

(cffi:foreign-type-size

'smoke-stack-item))

(get-first-argument method)))

- (return-type method))

+ (return-type method)

+ object)

t)

nil)))))

(call-default ()

@@ -353,7 +361,9 @@

:interactive (lambda ()

(format *query-io* "~&Enter a new return value: ")

(multiple-value-list (eval (read *query-io*))))

- (put-returnvalue stack return-value (return-type method))

+ (put-returnvalue stack return-value

+ (return-type method)

+ (get-object object))

(return-from dispatch-method t))

(return ()

:report (lambda (stream)

@@ -434,16 +444,16 @@

(add-object ret))

ret))

-(defvar *cxx-wrapper-objects* (make-synchronized-hash-table))

-

-(defun keep-wrapper (object)

- (assert (not (gethash object *cxx-wrapper-objects*)))

- (setf (gethash object *cxx-wrapper-objects*) object))

+(defun keep-wrapper (object new-owner)

+ (assert (not (member object (owned-objects new-owner)))

+ ()

+ "~A has already been called for ~A." #'keep-wrapper object)

+ (push object (owned-objects new-owner)))

-(defun remove-wrapper-object (object)

- (remhash object *cxx-wrapper-objects*))

+(defun remove-wrapper-object (object owner)

+ (remove object (owned-objects owner)))

-(defun disown-object (object)

+(defun transfer-ownership-to (object new-owner)

"Transfers the ownership of OBJECT to C++."

(cancel-finalization object)

(if (typep (class-of object) 'cxx:class)

@@ -452,24 +462,16 @@

()

"The ownership of the object ~A is transfered to C++, but

it has a nonvirtual destructor." object)

- (keep-wrapper object))

+ (keep-wrapper object new-owner))

(when (and (typep object 'smoke-standard-object)

(not (virtual-destructor-p (class-of object))))

(remove-object (pointer object)))))

-

-(defun take-ownership (object)

+(defun take-ownership (object &optional current-owner)

"Assigns the ownership of OBJECT to Lisp. i.e.:

cl-smoke is responsible for deleting the object."

- (remove-wrapper-object object)

+ (when current-owner

+ (remove-wrapper-object object current-owner))

(let ((finalizer (make-finalize object)))

(finalize object finalizer)))

-

-;(eval-when (:load-toplevel)

-; (trace disown-object

-; keep-wrapper

-; remove-wrapper-object

-;take-ownership

-;put-returnvalue

-;))

--- old-smoke/src/objects/enum.lisp 2014-09-28 09:40:55.000000000 +0200

+++ new-smoke/src/objects/enum.lisp 2014-09-28 09:40:55.000000000 +0200

@@ -75,3 +75,6 @@

(defun enum-logand (&rest enums)

(apply #'logand (mapcar #'value enums)))

+

+(defun enum-logior (&rest enums)

+ (apply #'logior (mapcar #'value enums)))

--- old-smoke/src/package.lisp 2014-09-28 09:40:55.000000000 +0200

+++ new-smoke/src/package.lisp 2014-09-28 09:40:55.000000000 +0200

@@ -3,6 +3,7 @@

(:export #:enum

#:enum=

#:enum-logand

+ #:enum-logior

#:value

#:enum-type

#:enum-case

--- old-smoke/src/smoke.lisp 2014-09-28 09:40:55.000000000 +0200

+++ new-smoke/src/smoke.lisp 2014-09-28 09:40:55.000000000 +0200

@@ -188,6 +188,9 @@

smoke))

(defmacro define-takes-ownership (method lambda-list object)

- "Declares METHOD transfers the ownership of OBJECT to C++."

+ "Declares METHOD transfers the ownership of OBJECT to the

+first argument of LAMBDA-LIST."

`(defmethod ,method :before ,lambda-list

- (disown-object ,object)))

+ (transfer-ownership-to ,object ,(if (consp (first lambda-list))

+ (first (first lambda-list))

+ (first lambda-list)))))