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

Diff of /object.lisp

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

revision 3 by rklochkov, Fri May 4 11:25:20 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
26                    :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 29  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 68  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    (unless (null-pointer-p (pointer object))    ;(format t "Called free ~a~%" object)
75      (remhash (pointer-address (pointer object)) *objects*)    (with-slots (id pointer free-after) object
76      (remhash (id object) *objects-ids*)      (unless (null-pointer-p pointer)
77      (setf (pointer object) (null-pointer)        (remhash (pointer-address pointer) *objects*)
78            (id object) nil)))        (remhash id *objects-ids*)
79          (when free-after
80            (free-ptr (class-of object) pointer))
81          ;; if use (setf pointer (null-pointer)) then
82          ;;   (setf pointer) method is not called
83          (setf (pointer object) (null-pointer)
84                id  nil))))
85    
86  (defun find-object (pointer &optional class)  (defun find-object (pointer &optional class)
87    "Returns lisp object for an Object pointer.    "Returns lisp object for an Object pointer.
# Line 90  If not found or found with wrong class, Line 99  If not found or found with wrong class,
99              (or try-find (make-instance class              (or try-find (make-instance class
100                                          :pointer pointer                                          :pointer pointer
101                                          :free-after nil)))                                          :free-after nil)))
102          try-find))))          (or try-find pointer)))))
103    
104  (defun object-by-id (id-key)  (defun object-by-id (id-key)
105    (gethash id-key *objects-ids*))    (gethash id-key *objects-ids*))
# Line 132  If not found or found with wrong class, Line 141  If not found or found with wrong class,
141    value)    value)
142    
143  (defmethod translate-from-foreign (ptr (cffi-object cffi-object))  (defmethod translate-from-foreign (ptr (cffi-object cffi-object))
144    (find-object ptr (object-class cffi-object)))    (find-object ptr (object-class cffi-object)))
   
   
   

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

  ViewVC Help
Powered by ViewVC 1.1.5