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

Diff of /object.lisp

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

revision 1 by rklochkov, Thu Feb 9 15:53:55 2012 UTC revision 7 by rklochkov, Thu Aug 9 16:55:23 2012 UTC
# Line 22  Line 22 
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")
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 31  shouldn't be stored in *OBJECTS*. Stored Line 33  shouldn't be stored in *OBJECTS*. Stored
33    (tg:cancel-finalization object)    (tg:cancel-finalization object)
34    (when (and (slot-value object 'free-after) (not (null-pointer-p value)))    (when (and (slot-value object 'free-after) (not (null-pointer-p value)))
35      (let ((class (class-of object)))      (let ((class (class-of object)))
36        (tg:finalize object (lambda ()        (format t "Set finalizer: ~a ~a ~a~%" object class value)
37          (tg:finalize object (lambda ()
38                                (format t "Finalize: ~a ~a~%" class value)
39                              (free-ptr class value)))))                              (free-ptr class value)))))
40                                          ; specialize EQL CLASS to override                                          ; specialize EQL CLASS to override
41    (unless (or (volatile object) (null-pointer-p value))    (unless (or (volatile object) (null-pointer-p value))
# Line 77  for example, by g_object_new.")) Line 81  for example, by g_object_new."))
81  If not found or found with wrong class, create new one with given CLASS"  If not found or found with wrong class, create new one with given CLASS"
82    (declare (type symbol class) (type foreign-pointer pointer))    (declare (type symbol class) (type foreign-pointer pointer))
83    (unless (null-pointer-p pointer)    (unless (null-pointer-p pointer)
84      (let  ((try-find (gethash (pointer-address pointer) *objects*)))      (let ((try-find (gethash (pointer-address pointer) *objects*)))
85        (if class        (if class
86            (progn            (progn
87              (unless (or (null try-find)              (unless (or (null try-find)
# Line 85  If not found or found with wrong class, Line 89  If not found or found with wrong class,
89                (progn                (progn
90                  (free try-find)                  (free try-find)
91                  (setf try-find nil)))                  (setf try-find nil)))
92              (or try-find (make-instance class :pointer pointer)))              (or try-find (make-instance class
93          try-find))))                                          :pointer pointer
94                                            :free-after nil)))
95            (or try-find pointer)))))
96    
97  (defun object-by-id (id-key)  (defun object-by-id (id-key)
98    (gethash id-key *objects-ids*))    (gethash id-key *objects-ids*))
# Line 117  If not found or found with wrong class, Line 123  If not found or found with wrong class,
123                                   (type cffi::foreign-pointer-type))                                   (type cffi::foreign-pointer-type))
124    (null-pointer))    (null-pointer))
125    
126    ;; nil = null string
127    (defmethod translate-to-foreign ((value null)
128                                     (type cffi::foreign-string-type))
129      (null-pointer))
130    
131    
132  (defmethod translate-to-foreign (value (type cffi-object))  (defmethod translate-to-foreign (value (type cffi-object))
133    (check-type value foreign-pointer)    (check-type value foreign-pointer)
134    value)    value)
135    
136  (defmethod translate-from-foreign (ptr (cffi-object cffi-object))  (defmethod translate-from-foreign (ptr (cffi-object cffi-object))
137    (find-object ptr (object-class cffi-object)))    (find-object ptr (object-class cffi-object)))
   
   
   

Legend:
Removed from v.1  
changed lines
  Added in v.7

  ViewVC Help
Powered by ViewVC 1.1.5