/[cffi-objects]/object.lisp
ViewVC logotype

Diff of /object.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 11 by rklochkov, Fri Aug 24 20:47:10 2012 UTC revision 12 by rklochkov, Sun Oct 7 11:59:54 2012 UTC
# Line 21  Line 21 
21               :initarg :volatile :initform t               :initarg :volatile :initform t
22               :documentation "Will not be saved in hash")               :documentation "Will not be saved in hash")
23     (free-after :type boolean :initarg :free-after :initform t     (free-after :type boolean :initarg :free-after :initform t
24                 :documentation "Should be freed by finalizer")                 :documentation "Should be freed by finalizer or FREE")
25     (initialized :type list :initform nil     (initialized :type list :initform nil
26                  :documentation "For SETF-INIT. To avoid double-init")                  :documentation "For SETF-INIT. To avoid double init")
27     (id :type symbol :accessor id :initarg :id :initform nil))     (id :type symbol :accessor id :initarg :id :initform nil))
28    (:documentation "Lisp wrapper for any object. VOLATILE slot set when object    (:documentation "Lisp wrapper for any object. VOLATILE slot set when object
29  shouldn't be stored in *OBJECTS*. Stored pointer GC'ed, if VOLATILE."))  shouldn't be stored in *OBJECTS*. Stored pointer GC'ed, if VOLATILE."))
# Line 31  shouldn't be stored in *OBJECTS*. Stored Line 31  shouldn't be stored in *OBJECTS*. Stored
31  (defmethod (setf pointer) :after (value (object object))  (defmethod (setf pointer) :after (value (object object))
32    (declare (type foreign-pointer value))    (declare (type foreign-pointer value))
33    (tg:cancel-finalization object)    (tg:cancel-finalization object)
34      ;(format t "Set pointer: ~a~%" object)
35    (when (and (slot-value object 'free-after) (not (null-pointer-p value)))    (when (and (slot-value object 'free-after) (not (null-pointer-p value)))
36      (let ((class (class-of object)))      (let ((class (class-of object)))
37        (format t "Set finalizer: ~a ~a ~a~%" object class value)        (format t "Set finalizer: ~a ~a ~a~%" object class value)
# Line 70  for example, by g_object_new.")) Line 71  for example, by g_object_new."))
71    (:documentation "Removes object pointer from lisp hashes."))    (:documentation "Removes object pointer from lisp hashes."))
72    
73  (defmethod free ((object object))  (defmethod free ((object object))
74      ;(format t "Called free ~a~%" object)
75    (with-slots (id pointer free-after) object    (with-slots (id pointer free-after) object
76      (unless (null-pointer-p pointer)      (unless (null-pointer-p pointer)
77        (remhash (pointer-address pointer) *objects*)        (remhash (pointer-address pointer) *objects*)
78        (remhash id *objects-ids*)        (remhash id *objects-ids*)
79        (when free-after        (when free-after
80          (free-ptr (class-of object) pointer))          (free-ptr (class-of object) pointer))
81        (setf pointer (null-pointer)        ;; if use (setf pointer (null-pointer)) then
82          ;;   (setf pointer) method is not called
83          (setf (pointer object) (null-pointer)
84              id  nil))))              id  nil))))
85    
86  (defun find-object (pointer &optional class)  (defun find-object (pointer &optional class)

Legend:
Removed from v.11  
changed lines
  Added in v.12

  ViewVC Help
Powered by ViewVC 1.1.5