repos
/
qt.gui
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
filehistory
normal
|
plain
|
shade
|
zebra
Fix potential lisp-object ID generation overflow for excessive lisp-object creation.
Annotate for file src/lisp-object.lisp
2010-01-10 tobias
1
(in-package :cl-smoke.qt-impl)
08:52:49 '
2
'
3
(defvar *cxx-lisp-objects* (smoke::make-synchronized-hash-table)
'
4
"Objects that are currently passed in a C++ class.")
'
5
'
6
(let ((id 0))
2009-07-02 tobias
7
(declare (type (smoke::c-integer :unsigned-int) id))
2010-01-10 tobias
8
(defun gen-cxx-lisp-object-id ()
08:52:49 '
9
"Returns a new unique ID."
2009-07-02 tobias
10
(loop do
19:37:42 '
11
(setf id
'
12
(logand (1- (expt 2 (* 8 (foreign-type-size :unsigned-int) )))
'
13
(1+ id)))
'
14
while (nth-value 1 (gethash id *cxx-lisp-objects*)))
'
15
id))
'
16
2010-01-10 tobias
17
(defcfun qt-smoke-setup-lisp-object :int
08:52:49 '
18
(destruct :pointer))
'
19
2009-07-02 tobias
20
(defcfun qt-smoke-lisp-object-id :unsigned-int
2010-01-10 tobias
21
(object :pointer))
08:52:49 '
22
2009-07-02 tobias
23
(defcfun qt-smoke-lisp-object-is-set :int
2010-01-10 tobias
24
(object :pointer))
08:52:49 '
25
'
26
(defcfun qt-smoke-make-lisp-object :pointer
2009-07-02 tobias
27
(id :unsigned-int))
2010-01-10 tobias
28
08:52:49 '
29
(defcfun qt-smoke-free-lisp-object :void
'
30
(object :pointer))
'
31
'
32
(defcallback destruct-cxx-lisp-object :void
2009-07-02 tobias
33
((id :unsigned-int))
2010-01-10 tobias
34
(remhash id *cxx-lisp-objects*))
08:52:49 '
35
'
36
(defvar *cxx-lisp-object-metatype* "Metatype ID of the C++ lisp_object.")
'
37
'
38
(eval-startup ()
'
39
(setf *cxx-lisp-object-metatype*
'
40
(qt-smoke-setup-lisp-object (callback destruct-cxx-lisp-object)))
'
41
(assert (>= *cxx-lisp-object-metatype*
'
42
(smoke::value qt:meta-type.+user+))
'
43
(*cxx-lisp-object-metatype*)
'
44
"setup of lisp-object failed"))
'
45
'
46
(defun make-cxx-lisp-object (object)
'
47
"Constructs a C++ object wrapper for OBJECT."
'
48
(let ((id (gen-cxx-lisp-object-id)))
'
49
(setf (gethash id *cxx-lisp-objects*) object)
'
50
(qt-smoke-make-lisp-object id)))
'
51
'
52
(defun free-cxx-lisp-object (pointer)
'
53
"Deletes the lisp_object at POINTER."
'
54
(qt-smoke-free-lisp-object pointer))
'
55
;; (qmetatype.destroy *cxx-lisp-object-metatype* pointer)) ;; FIXME use this?
'
56
'
57
(defun translate-cxx-lisp-object (pointer)
'
58
"Returns the object of the cxx-lisp-object at POINTER.
'
59
'
60
When being received as an argument by a slot,
'
61
the object must not be deallocated."
'
62
(multiple-value-bind (value present-p)
'
63
(gethash (qt-smoke-lisp-object-id pointer)
'
64
*cxx-lisp-objects*)
'
65
(assert present-p (value present-p)
'
66
"No object for ~A in ~A" pointer *cxx-lisp-objects*)
'
67
value))