repos
/
qt.gui
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
filehistory
normal
|
plain
|
shade
|
zebra
Break API compatibility for qt:with-app and qt:exec & spellcheck
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))
'
7
(defun gen-cxx-lisp-object-id ()
'
8
"Returns a new unique ID."
2009-07-02 tobias
9
(incf id)))
19:37:42 '
10
2010-01-10 tobias
11
(defcfun qt-smoke-setup-lisp-object :int
08:52:49 '
12
(destruct :pointer))
'
13
2009-07-02 tobias
14
(defcfun qt-smoke-lisp-object-id :int
2010-01-10 tobias
15
(object :pointer))
08:52:49 '
16
2009-07-02 tobias
17
(defcfun qt-smoke-lisp-object-set :int
2010-01-10 tobias
18
(object :pointer))
08:52:49 '
19
'
20
(defcfun qt-smoke-make-lisp-object :pointer
2009-07-02 tobias
21
(id :int))
2010-01-10 tobias
22
08:52:49 '
23
(defcfun qt-smoke-free-lisp-object :void
'
24
(object :pointer))
'
25
'
26
(defcallback destruct-cxx-lisp-object :void
2009-07-02 tobias
27
((id :int))
2010-01-10 tobias
28
(remhash id *cxx-lisp-objects*))
08:52:49 '
29
'
30
(defvar *cxx-lisp-object-metatype* "Metatype ID of the C++ lisp_object.")
'
31
'
32
(eval-startup ()
'
33
(setf *cxx-lisp-object-metatype*
'
34
(qt-smoke-setup-lisp-object (callback destruct-cxx-lisp-object)))
'
35
(assert (>= *cxx-lisp-object-metatype*
'
36
(smoke::value qt:meta-type.+user+))
'
37
(*cxx-lisp-object-metatype*)
'
38
"setup of lisp-object failed"))
'
39
'
40
(defun make-cxx-lisp-object (object)
'
41
"Constructs a C++ object wrapper for OBJECT."
'
42
(let ((id (gen-cxx-lisp-object-id)))
'
43
(setf (gethash id *cxx-lisp-objects*) object)
'
44
(qt-smoke-make-lisp-object id)))
'
45
'
46
(defun free-cxx-lisp-object (pointer)
'
47
"Deletes the lisp_object at POINTER."
'
48
(qt-smoke-free-lisp-object pointer))
'
49
;; (qmetatype.destroy *cxx-lisp-object-metatype* pointer)) ;; FIXME use this?
'
50
'
51
(defun translate-cxx-lisp-object (pointer)
'
52
"Returns the object of the cxx-lisp-object at POINTER.
'
53
2009-07-01 tobias
54
When being received as an argument by a slot,
2010-01-10 tobias
55
the object must not be deallocated."
08:52:49 '
56
(multiple-value-bind (value present-p)
'
57
(gethash (qt-smoke-lisp-object-id pointer)
'
58
*cxx-lisp-objects*)
'
59
(assert present-p (value present-p)
'
60
"No object for ~A in ~A" pointer *cxx-lisp-objects*)
'
61
value))