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

Contents of /object.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3 - (show annotations)
Fri May 4 11:25:20 2012 UTC (23 months, 1 week ago) by rklochkov
File size: 5120 byte(s)
Fixes with GC

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 (id :type symbol :accessor id :initarg :id :initform nil))
26 (:documentation "Lisp wrapper for any object. VOLATILE slot set when object
27 shouldn't be stored in *OBJECTS*. Stored pointer GC'ed, if VOLATILE."))
28
29 (defmethod (setf pointer) :after (value (object object))
30 (declare (type foreign-pointer value))
31 (tg:cancel-finalization object)
32 (when (and (slot-value object 'free-after) (not (null-pointer-p value)))
33 (let ((class (class-of object)))
34 (format t "Set finalizer: ~a ~a ~a~%" object class value)
35 (tg:finalize object (lambda ()
36 (format t "Finalize: ~a ~a~%" class value)
37 (free-ptr class value)))))
38 ; specialize EQL CLASS to override
39 (unless (or (volatile object) (null-pointer-p value))
40 (setf (gethash (pointer-address value) *objects*) object)
41 (when (id object)
42 (let ((cur-obj (gethash (id object) *objects-ids*)))
43 (unless (or (null cur-obj) (eq cur-obj object))
44 (warn "ID ~a for object ~a already set for ~a~%"
45 (id object) object (gethash (id object) *objects-ids*)))
46 (setf (gethash (id object) *objects-ids*) object)))))
47
48 (defgeneric gconstructor (object &rest initargs)
49 (:documentation "Called during initialization of OBJECT instance.
50 Should return a pointer to foreign OBJECT instance,
51 for example, by g_object_new."))
52
53 (defmethod gconstructor (something-bad &rest rest)
54 (warn "No constructor for ~a ~a~%" something-bad rest))
55
56 (defmethod shared-initialize :after ((object object) slot-names
57 &rest initargs
58 &key pointer &allow-other-keys)
59 (unless pointer
60 (setf (pointer object) (apply #'gconstructor object initargs))))
61
62 (defmethod pointer (something-bad)
63 (declare (ignore something-bad))
64 "Empty method to return null-pointer for non-objects"
65 (null-pointer))
66
67 (defgeneric free (object)
68 (:documentation "Removes object pointer from lisp hashes."))
69
70 (defmethod free ((object object))
71 (unless (null-pointer-p (pointer object))
72 (remhash (pointer-address (pointer object)) *objects*)
73 (remhash (id object) *objects-ids*)
74 (setf (pointer object) (null-pointer)
75 (id object) nil)))
76
77 (defun find-object (pointer &optional class)
78 "Returns lisp object for an Object pointer.
79 If not found or found with wrong class, create new one with given CLASS"
80 (declare (type symbol class) (type foreign-pointer pointer))
81 (unless (null-pointer-p pointer)
82 (let ((try-find (gethash (pointer-address pointer) *objects*)))
83 (if class
84 (progn
85 (unless (or (null try-find)
86 (eq (class-of try-find) (find-class class)))
87 (progn
88 (free try-find)
89 (setf try-find nil)))
90 (or try-find (make-instance class
91 :pointer pointer
92 :free-after nil)))
93 try-find))))
94
95 (defun object-by-id (id-key)
96 (gethash id-key *objects-ids*))
97
98 ;; Type OBJECT
99 ;; converts class object to pointer and vice versa
100
101 (define-foreign-type cffi-object ()
102 ((class :initarg :class :accessor object-class))
103 (:actual-type :pointer))
104
105 (define-parse-method object (&optional class)
106 (make-instance 'cffi-object :class class))
107
108 (defmethod translate-to-foreign ((value null) (type cffi-object))
109 (null-pointer))
110
111 (defmethod translate-to-foreign ((value object) (type cffi-object))
112 (pointer value))
113
114 ;; Hack: redefine translator for :pointer to be able to use
115 ;; objects or nulls instead of pointer
116 (defmethod translate-to-foreign ((value object)
117 (type cffi::foreign-pointer-type))
118 (pointer value))
119
120 (defmethod translate-to-foreign ((value null)
121 (type cffi::foreign-pointer-type))
122 (null-pointer))
123
124 ;; nil = null string
125 (defmethod translate-to-foreign ((value null)
126 (type cffi::foreign-string-type))
127 (null-pointer))
128
129
130 (defmethod translate-to-foreign (value (type cffi-object))
131 (check-type value foreign-pointer)
132 value)
133
134 (defmethod translate-from-foreign (ptr (cffi-object cffi-object))
135 (find-object ptr (object-class cffi-object)))
136
137
138

  ViewVC Help
Powered by ViewVC 1.1.5