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

Contents of /object.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 11 - (hide annotations)
Fri Aug 24 20:47:10 2012 UTC (19 months, 3 weeks ago) by rklochkov
File size: 5322 byte(s)
Bugfix
1 rklochkov 1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2     ;;;
3     ;;; object.lisp --- CFFI type OBJECT
4     ;;;
5     ;;; Copyright (C) 2007, Roman Klochkov <monk@slavsoft.surgut.ru>
6     ;;;
7    
8     (in-package :cffi-objects)
9    
10     (defvar *objects* (make-hash-table)
11     "Hash table: foreign-pointer address as integer -> lisp object")
12    
13     (defvar *objects-ids* (make-hash-table)
14     "Hash table: atom -> lisp object")
15    
16     (defclass object ()
17     ((pointer :accessor pointer :initarg :pointer
18     :initform (null-pointer) :type foreign-pointer)
19     ;; by default object shouldn't be stored unless it is GtkObject
20     (volatile :type boolean :accessor volatile
21     :initarg :volatile :initform t
22     :documentation "Will not be saved in hash")
23     (free-after :type boolean :initarg :free-after :initform t
24     :documentation "Should be freed by finalizer")
25 rklochkov 7 (initialized :type list :initform nil
26     :documentation "For SETF-INIT. To avoid double-init")
27 rklochkov 1 (id :type symbol :accessor id :initarg :id :initform nil))
28     (:documentation "Lisp wrapper for any object. VOLATILE slot set when object
29     shouldn't be stored in *OBJECTS*. Stored pointer GC'ed, if VOLATILE."))
30    
31     (defmethod (setf pointer) :after (value (object object))
32     (declare (type foreign-pointer value))
33     (tg:cancel-finalization object)
34     (when (and (slot-value object 'free-after) (not (null-pointer-p value)))
35     (let ((class (class-of object)))
36 rklochkov 3 (format t "Set finalizer: ~a ~a ~a~%" object class value)
37     (tg:finalize object (lambda ()
38     (format t "Finalize: ~a ~a~%" class value)
39 rklochkov 1 (free-ptr class value)))))
40     ; specialize EQL CLASS to override
41     (unless (or (volatile object) (null-pointer-p value))
42     (setf (gethash (pointer-address value) *objects*) object)
43     (when (id object)
44     (let ((cur-obj (gethash (id object) *objects-ids*)))
45     (unless (or (null cur-obj) (eq cur-obj object))
46     (warn "ID ~a for object ~a already set for ~a~%"
47     (id object) object (gethash (id object) *objects-ids*)))
48     (setf (gethash (id object) *objects-ids*) object)))))
49    
50     (defgeneric gconstructor (object &rest initargs)
51     (:documentation "Called during initialization of OBJECT instance.
52     Should return a pointer to foreign OBJECT instance,
53     for example, by g_object_new."))
54    
55     (defmethod gconstructor (something-bad &rest rest)
56     (warn "No constructor for ~a ~a~%" something-bad rest))
57    
58     (defmethod shared-initialize :after ((object object) slot-names
59     &rest initargs
60     &key pointer &allow-other-keys)
61     (unless pointer
62     (setf (pointer object) (apply #'gconstructor object initargs))))
63    
64     (defmethod pointer (something-bad)
65     (declare (ignore something-bad))
66     "Empty method to return null-pointer for non-objects"
67     (null-pointer))
68    
69     (defgeneric free (object)
70     (:documentation "Removes object pointer from lisp hashes."))
71    
72     (defmethod free ((object object))
73 rklochkov 11 (with-slots (id pointer free-after) object
74     (unless (null-pointer-p pointer)
75     (remhash (pointer-address pointer) *objects*)
76     (remhash id *objects-ids*)
77     (when free-after
78     (free-ptr (class-of object) pointer))
79     (setf pointer (null-pointer)
80     id nil))))
81 rklochkov 1
82     (defun find-object (pointer &optional class)
83     "Returns lisp object for an Object pointer.
84     If not found or found with wrong class, create new one with given CLASS"
85     (declare (type symbol class) (type foreign-pointer pointer))
86     (unless (null-pointer-p pointer)
87 rklochkov 3 (let ((try-find (gethash (pointer-address pointer) *objects*)))
88 rklochkov 1 (if class
89     (progn
90     (unless (or (null try-find)
91     (eq (class-of try-find) (find-class class)))
92     (progn
93     (free try-find)
94     (setf try-find nil)))
95 rklochkov 3 (or try-find (make-instance class
96     :pointer pointer
97     :free-after nil)))
98 rklochkov 4 (or try-find pointer)))))
99 rklochkov 1
100     (defun object-by-id (id-key)
101     (gethash id-key *objects-ids*))
102    
103     ;; Type OBJECT
104     ;; converts class object to pointer and vice versa
105    
106     (define-foreign-type cffi-object ()
107     ((class :initarg :class :accessor object-class))
108     (:actual-type :pointer))
109    
110     (define-parse-method object (&optional class)
111     (make-instance 'cffi-object :class class))
112    
113     (defmethod translate-to-foreign ((value null) (type cffi-object))
114     (null-pointer))
115    
116     (defmethod translate-to-foreign ((value object) (type cffi-object))
117     (pointer value))
118    
119     ;; Hack: redefine translator for :pointer to be able to use
120     ;; objects or nulls instead of pointer
121     (defmethod translate-to-foreign ((value object)
122     (type cffi::foreign-pointer-type))
123     (pointer value))
124    
125     (defmethod translate-to-foreign ((value null)
126     (type cffi::foreign-pointer-type))
127     (null-pointer))
128    
129 rklochkov 3 ;; nil = null string
130     (defmethod translate-to-foreign ((value null)
131     (type cffi::foreign-string-type))
132     (null-pointer))
133    
134    
135 rklochkov 1 (defmethod translate-to-foreign (value (type cffi-object))
136     (check-type value foreign-pointer)
137     value)
138    
139     (defmethod translate-from-foreign (ptr (cffi-object cffi-object))
140 rklochkov 5 (find-object ptr (object-class cffi-object)))

  ViewVC Help
Powered by ViewVC 1.1.5