Sun May 24 13:30:05 CEST 2009 Tobias Rautenkranz * cleanup finalization stuff diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp --- old-smoke/src/clos.lisp 2014-10-01 19:32:01.000000000 +0200 +++ new-smoke/src/clos.lisp 2014-10-01 19:32:02.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)) diff -rN -u old-smoke/src/object-map.lisp new-smoke/src/object-map.lisp --- old-smoke/src/object-map.lisp 2014-10-01 19:32:01.000000000 +0200 +++ new-smoke/src/object-map.lisp 2014-10-01 19:32:02.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)) diff -rN -u old-smoke/src/objects/class.lisp new-smoke/src/objects/class.lisp --- old-smoke/src/objects/class.lisp 2014-10-01 19:32:01.000000000 +0200 +++ new-smoke/src/objects/class.lisp 2014-10-01 19:32:02.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 diff -rN -u old-smoke/src/objects/stack.lisp new-smoke/src/objects/stack.lisp --- old-smoke/src/objects/stack.lisp 2014-10-01 19:32:01.000000000 +0200 +++ new-smoke/src/objects/stack.lisp 2014-10-01 19:32:02.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" diff -rN -u old-smoke/src/objects/type.lisp new-smoke/src/objects/type.lisp --- old-smoke/src/objects/type.lisp 2014-10-01 19:32:01.000000000 +0200 +++ new-smoke/src/objects/type.lisp 2014-10-01 19:32:02.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)." diff -rN -u old-smoke/src/smoke.lisp new-smoke/src/smoke.lisp --- old-smoke/src/smoke.lisp 2014-10-01 19:32:01.000000000 +0200 +++ new-smoke/src/smoke.lisp 2014-10-01 19:32:02.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."