repos
/
qt.core
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
initial import
Annotate for file src/lisp-object.lisp
2009-04-05 tobias
1
(in-package :qt)
17:56:16 '
2
(declaim (optimize (debug 3)))
'
3
'
4
(defvar *cxx-lisp-objects* (make-hash-table)
'
5
"Objects that are currently passed in a C++ class.")
'
6
'
7
(let ((id 0))
'
8
(defun gen-cxx-lisp-object-id ()
'
9
"Returns a new unique ID."
'
10
(incf id)))
'
11
'
12
(defcfun qt-smoke-setup-lisp-object :int
'
13
(destruct :pointer))
'
14
'
15
(defcfun qt-smoke-lisp-object-id :int
'
16
(object :pointer))
'
17
'
18
(defcfun qt-smoke-lisp-object-set :int
'
19
(object :pointer))
'
20
'
21
(defcfun qt-smoke-make-lisp-object :pointer
'
22
(id :int))
'
23
'
24
(defcfun qt-smoke-free-lisp-object :void
'
25
(object :pointer))
'
26
'
27
(defcallback destruct-cxx-lisp-object :void
'
28
((id :int))
'
29
(remhash id *cxx-lisp-objects*))
'
30
'
31
(defvar *cxx-lisp-object-metatype*)
'
32
'
33
(eval-when (:load-toplevel)
'
34
(setf *cxx-lisp-object-metatype*
'
35
(qt-smoke-setup-lisp-object (callback destruct-cxx-lisp-object)))
'
36
(assert (>= *cxx-lisp-object-metatype*
'
37
(smoke::value meta-type.+user+))
'
38
(*cxx-lisp-object-metatype*)
'
39
"setup of lisp-object failed"))
'
40
'
41
(defun make-cxx-lisp-object (object)
'
42
"Constructs a C++ object wrapper for OBJECT."
'
43
(let ((id (gen-cxx-lisp-object-id)))
'
44
(setf (gethash id *cxx-lisp-objects*) object)
'
45
(qt-smoke-make-lisp-object id)))
'
46
'
47
(defun free-cxx-lisp-object (pointer)
'
48
"Deletes the lisp_object at POINTER."
'
49
(qt-smoke-free-lisp-object pointer))
'
50
;; (qmetatype.destroy *cxx-lisp-object-metatype* pointer)) ;; FIXME use this?
'
51
'
52
(defun translate-cxx-lisp-object (pointer)
'
53
"Returns the object of the cxx-lisp-object at POINTER.
'
54
'
55
When beeing received as an argument by a slot,
'
56
the object must not be deallocated."
'
57
(multiple-value-bind (value present-p)
'
58
(gethash (qt-smoke-lisp-object-id pointer)
'
59
*cxx-lisp-objects*)
'
60
(assert present-p (value present-p)
'
61
"No object for ~A in ~A" pointer *cxx-lisp-objects*)
'
62
value))