Sun May 24 13:30:05 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* cleanup finalization stuff

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

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

@@ -110,14 +110,7 @@

(defclass smoke-standard-object ()

((pointer :reader pointer :initarg :pointer

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

- (owned-p :accessor owned-p :initarg :owned-p

- :initform t

- :documentation "T when the object is owned by Lisp and

-NIL when C++ is the owner.")

- (const-p :reader const-p :initarg :const-p

- :initform nil

- :documentation "T when the object is const and NIL otherwise."))

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

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

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

@@ -125,12 +118,7 @@

(princ (pointer object) stream)))

(defclass smoke-standard-class (standard-class smoke-class)

- ((enumerations :initform (make-hash-table)

- :initarg :enumerations

- :reader enumerations

- :documentation "The enumerations of the class.

-Maps the type-id of the enumeration to a hash-table that

-maps an enum value to a symbol."))

+ ()

(:documentation "A Smoke C++ class"))

(defclass smoke-wrapper-class (smoke-standard-class)

@@ -204,10 +192,11 @@

:direct-superclasses direct-superclasses

args)))

-(defun smoke-class-symbol (class)

- (if (external-p class)

- (class-name (find-smoke-class class))

- (lispify (name class))))

+(defun smoke-class-symbol (smoke-class)

+ "Returns the Lisp class-name of SMOKE-CLASS:"

+ (if (external-p smoke-class)

+ (class-name (find-smoke-class smoke-class))

+ (lispify (name smoke-class))))

(defun make-smoke-classes (smoke)

@@ -292,12 +281,13 @@

"The type ~A of the value ~A is not a class."

(name type) value)

(setf (foreign-slot-value stack 'smoke-stack-item 'class)

- (pointer value))

+ (cast value (find-smoke-class (get-class type))))

+ ;(pointer value))

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

- (cancel-finalization value) ;; Fixme mark object as invalid or copy it

- ;(remove-object (pointer value))

- (remove-if-exists (pointer value));;FIXME!

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

+ (cancel-finalization value)

+ (unless (virtual-destructor-p (class-of value))

+ (remove-object (pointer value))))) ;; Fixme mark object as invalid or copy it

+

(defmethod set-returnvalue (stack (value integer) type)

(setf (foreign-slot-value stack 'smoke-stack-item 'int)

@@ -316,10 +306,6 @@

(optimize (speed 3)))

(symbol-function (lispify (name smoke-method) "CXX")))

-;(eval-startup (:execute)

-; (memoize:memoize-function 'get-gf-for-method)

-; (memoize:clear-memoized-function 'get-gf-for-method))

-

(defcallback dispatch-method :boolean

((binding :pointer)

(method smoke-index)

@@ -406,12 +392,14 @@

(unless (slot-boundp object 'pointer)

(setf (slot-value object 'pointer) (call-constructor object args))

(set-binding object (binding (smoke (class-of object))))

- (setf (slot-value object 'owned-p) t)

+ (take-ownership object)

(add-object object)))

(defmethod instance-to-lisp (pointer class type)

(let ((ret (make-instance class

- :owned-p (stack-p type)

:pointer pointer)))

+ (when (stack-p type)

+ (take-ownership ret)

+ (add-object ret))

ret))

--- old-smoke/src/object-map.lisp 2014-09-28 09:40:33.000000000 +0200

+++ new-smoke/src/object-map.lisp 2014-09-28 09:40:33.000000000 +0200

@@ -58,12 +58,17 @@

condition))))))

+(defun take-ownership (object)

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

+cl-smoke is responsible for deleting the object."

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

+ (finalize object finalizer)))

+

(defun add-object (object)

+ "Adds OBJECT to the pointer -> object map. It can later be retrived

+with GET-OBJECT."

(assert (not (has-pointer-p (pointer object)))

()

"There exists already a object ~A for the pointer of ~A."

(get-object (pointer object)) object)

- (when (owned-p object)

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

- (finalize object finalizer)))

(setf (get-object (pointer object)) object))

--- old-smoke/src/objects/class.lisp 2014-09-28 09:40:33.000000000 +0200

+++ new-smoke/src/objects/class.lisp 2014-09-28 09:40:33.000000000 +0200

@@ -47,6 +47,10 @@

"Returns T when CLASS has a constructor; NIL otherwise."

(/= 0 (get-flag class :constructor)))

+(defun virtual-destructor-p (class)

+ "Returns T when CLASS has a virtual destructor and NIL otherwise."

+ (/= 0 (get-flag class :virtual-destructor)))

+

(define-condition undefined-class (cell-error)

((smoke-name :initarg :smoke-name

:initform nil

--- old-smoke/src/objects/stack.lisp 2014-09-28 09:40:33.000000000 +0200

+++ new-smoke/src/objects/stack.lisp 2014-09-28 09:40:33.000000000 +0200

@@ -161,10 +161,11 @@

(defun class-to-lisp (stack-item type)

"Returns the Lisp representation for STACK-ITEM of type C++ class."

- (object-to-lisp (foreign-slot-value stack-item

- 'smoke-stack-item

- 'class)

- type))

+ (let ((object (object-to-lisp (foreign-slot-value stack-item

+ 'smoke-stack-item

+ 'class)

+ type)))

+ object))

(defun type-to-lisp (stack-item type)

"Returns the Lisp representation of STACK-ITEM"

--- old-smoke/src/objects/type.lisp 2014-09-28 09:40:33.000000000 +0200

+++ new-smoke/src/objects/type.lisp 2014-09-28 09:40:33.000000000 +0200

@@ -33,20 +33,25 @@

(id type2))))

(defmethod get-flag ((type smoke-type) flag)

- (boole boole-and (get-struct-slot-value type 'flags)

- (foreign-enum-value 'smoke-type-flags flag)))

+ (logand (get-struct-slot-value type 'flags)

+ #xF0 ;; = ! 0x0F

+ (foreign-enum-value 'smoke-type-flags flag)))

+

+(defun get-allocation-flag (type)

+ (logand (get-struct-slot-value type 'flags)

+ #x30))

(defun stack-p (type)

"Returns T when TYPE is stored on the stack; NIL otherwise."

- (/= 0 (get-flag type :stack)))

+ (= (get-allocation-flag type) (get-flag type :stack)))

(defun reference-p (type)

"Returns T when TYPE is a reference ('type&'); NIL otherwise."

- (/= 0 (get-flag type :reference)))

+ (= (get-allocation-flag type) (get-flag type :reference)))

(defun pointer-p (type)

"Returns T when TYPE is a pointer ('type*'); NIL otherwise."

- (/= 0 (get-flag type :pointer)))

+ (= (get-allocation-flag type) (get-flag type :pointer)))

(defmethod const-p ((type smoke-type))

"Returns T when TYPE is const; NIL otherwise."

@@ -59,8 +64,8 @@

(defun type-id (type)

"Returns the ID of TYPE."

- (boole boole-and (get-struct-slot-value type 'flags)

- (foreign-enum-value 'smoke-type-flags :type-id)))

+ (logand (get-struct-slot-value type 'flags)

+ (foreign-enum-value 'smoke-type-flags :type-id)))

(defun void-p (type)

"Return T when TYPE is a void type (no value)."

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

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

@@ -78,6 +78,7 @@

(add-object object)

object))

+

(defun delete-pointer (pointer class)

"Destructs the object at POINTER of type CLASS.

Calls the destrutor and frees the memory."