repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Smoke::t_class is now also used for classes not wrapped by Smoke & remove global-space part from enum symbols.
Annotate for file src/objects/stack.lisp
2009-04-05 tobias
1
(in-package #:smoke)
15:36:29 '
2
2009-07-08 tobias
3
(declaim (inline %make-call-stack))
20:41:19 '
4
(defstruct (call-stack (:constructor %make-call-stack))
'
5
(pointer (null-pointer) :type foreign-pointer)
'
6
(top (null-pointer) :type foreign-pointer))
2009-04-05 tobias
7
2009-05-27 tobias
8
(defgeneric size (object))
2009-04-05 tobias
9
(defmethod size ((stack call-stack))
15:36:29 '
10
"Returns the size (number of arguments) of STACK."
2009-07-22 tobias
11
(/ (- (pointer-address (call-stack-top stack))
22:26:05 '
12
(pointer-address (call-stack-pointer stack)))
'
13
(foreign-type-size 'smoke-stack-item)))
2009-04-05 tobias
14
15:36:29 '
15
(defun make-call-stack (smoke-stack)
2009-07-08 tobias
16
(declare (type foreign-pointer smoke-stack)
20:41:19 '
17
(optimize (speed 3)))
'
18
(%make-call-stack
'
19
:pointer smoke-stack
2009-08-02 tobias
20
:top (inc-pointer smoke-stack #.(foreign-type-size 'smoke-stack-item))))
2009-04-05 tobias
21
15:36:29 '
22
(defun push-stack (stack value type)
2009-08-02 tobias
23
(setf (foreign-slot-value (call-stack-top stack) 'smoke-stack-item type)
10:12:41 '
24
value)
2009-07-08 tobias
25
(incf-pointer (call-stack-top stack) #.(foreign-type-size 'smoke-stack-item)))
2009-06-22 tobias
26
12:18:08 '
27
(define-compiler-macro push-stack (&whole form stack value type)
'
28
(if (constantp type)
'
29
`(progn
2009-07-08 tobias
30
(setf (foreign-slot-value (call-stack-top ,stack)
2009-08-02 tobias
31
'smoke-stack-item ,type)
10:12:41 '
32
,value)
2009-07-08 tobias
33
(incf-pointer (call-stack-top ,stack)
20:41:19 '
34
,(foreign-type-size 'smoke-stack-item)))
2009-06-22 tobias
35
form))
2009-06-12 tobias
36
12:21:44 '
37
(defclass smoke-standard-object ()
'
38
((pointer :reader pointer
2009-07-08 tobias
39
:type foreign-pointer
2009-06-12 tobias
40
:initarg :pointer
12:21:44 '
41
:documentation "Pointer to the C++ object.")
2009-08-27 tobias
42
(const-p :reader const-p
11:43:13 '
43
:initarg :const-p
'
44
:initform nil
'
45
:documentation "Returns true when the object is const and nil otherwise.")
2009-06-30 tobias
46
#+clisp (finalizer :type list :initform (list nil))
2009-06-12 tobias
47
;; We can not have a global table of objects owned by C++,
2009-07-01 tobias
48
;; since then they would be always reachable from Lisp and thus
2009-06-12 tobias
49
;; cycles would never be garbage collected.
12:21:44 '
50
(owned-objects :accessor owned-objects
'
51
:initform nil
'
52
:type list
2009-07-01 tobias
53
:documentation "Objects owned by the C++ instance."))
2009-06-12 tobias
54
(:documentation "The standard superclass for Smoke classes."))
2009-04-05 tobias
55
2009-05-26 tobias
56
(defun push-smoke-stack (stack value type-id)
2009-06-22 tobias
57
(declare (type (smoke-index 0) type-id)
12:18:08 '
58
(type call-stack stack)
'
59
(optimize (speed 3)))
2009-04-05 tobias
60
(ecase type-id
15:36:29 '
61
(0 (push-stack stack value 'voidp))
'
62
(1 (push-stack stack value 'bool))
2009-04-12 tobias
63
(2 (push-stack stack (char-code value) 'char))
2009-04-05 tobias
64
(3 (push-stack stack value 'uchar))
15:36:29 '
65
(4 (push-stack stack value 'short))
'
66
(5 (push-stack stack value 'ushort))
'
67
(6 (push-stack stack value 'int))
'
68
(7 (push-stack stack value 'uint))
'
69
(8 (push-stack stack value 'long))
'
70
(9 (push-stack stack value 'ulong))
'
71
(10 (push-stack stack value 'float))
'
72
(11 (push-stack stack value 'double))
'
73
(12 (push-stack stack (value value) 'enum-value))
2009-05-26 tobias
74
(13 (if (typep value 'smoke-standard-object)
09:54:47 '
75
;; FIXME call pointer in overload resolution
'
76
(push-stack stack (pointer value) 'class)
'
77
(push-stack stack value 'class)))))
2009-04-05 tobias
78
15:36:29 '
79
(defun set-smoke-stack (stack args arguments)
'
80
"Pushes the arguments ARGS onto the Smoke stack STACK."
'
81
(when (null args)
'
82
(assert (null arguments)
'
83
()
'
84
"To few arguments supplied. Missing: ~A" arguments))
'
85
(unless (null args)
'
86
(assert (not (null arguments))
'
87
()
2009-07-01 tobias
88
"To many arguments supplied (Arguments ~A)." args)
2009-05-26 tobias
89
(if (typep (first arguments) 'smoke-type)
09:54:47 '
90
(push-smoke-stack stack (first args) (type-id (first arguments)))
'
91
(push-stack stack (first args) 'class)) ;; Used for :qt lisp-object
'
92
(set-smoke-stack stack (rest args) (rest arguments))))
2009-04-05 tobias
93
15:36:29 '
94
(defmacro with-stack ((stack args types) &body body)
'
95
(let ((smoke-stack (gensym "STACK")))
'
96
`(with-foreign-object (,smoke-stack 'smoke-stack-item (1+ (length ,args)))
'
97
(let ((,stack (make-call-stack ,smoke-stack)))
'
98
(set-smoke-stack ,stack ,args
'
99
,types)
2009-05-26 tobias
100
,@body))))
2009-04-05 tobias
101
2009-08-27 tobias
102
(defvar *to-lisp-translations* (make-hash-table :test 'equal))
11:43:13 '
103
2009-04-05 tobias
104
(defun enum-to-lisp (stack-item type)
15:36:29 '
105
"Returns the Lisp representation for STACK-ITEM of the basic C type TYPE."
2009-06-22 tobias
106
(declare (optimize (speed 3)))
2009-04-05 tobias
107
(ecase (type-id type)
2009-09-09 tobias
108
((0 13) (if-let ((translation (gethash (name type) *to-lisp-translations*)))
13:22:32 '
109
(let ((pointer (foreign-slot-value stack-item 'smoke-stack-item
'
110
'voidp)))
'
111
(prog1 (funcall (car translation) pointer)
'
112
(when (stack-p type)
'
113
(funcall (cdr translation) pointer))))
'
114
(error "Do not know how to convert the type ~A to Lisp." type)))
2009-04-05 tobias
115
(1 (foreign-slot-value stack-item 'smoke-stack-item 'bool))
15:36:29 '
116
(2 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'char)))
'
117
(3 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'uchar)))
'
118
(4 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'short)))
'
119
(5 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'ushort)))
'
120
(6 (foreign-slot-value stack-item 'smoke-stack-item 'int))
'
121
(7 (foreign-slot-value stack-item 'smoke-stack-item 'uint))
'
122
(8 (foreign-slot-value stack-item 'smoke-stack-item 'long))
'
123
(9 (foreign-slot-value stack-item 'smoke-stack-item 'ulong))
'
124
(10 (foreign-slot-value stack-item 'smoke-stack-item 'float))
'
125
(11 (foreign-slot-value stack-item 'smoke-stack-item 'double))
'
126
(12 (make-instance 'enum
2009-08-02 tobias
127
:value (foreign-slot-value stack-item 'smoke-stack-item
10:12:41 '
128
'enum-value)
2009-04-05 tobias
129
:type type))))
15:36:29 '
130
'
131
(defgeneric instance-to-lisp (pointer class type)
2009-06-22 tobias
132
(declare (optimize (speed 3)))
2009-07-01 tobias
133
(:documentation "Returns a CLOS instance for POINTER."))
2009-04-05 tobias
134
15:36:29 '
135
(defun object-to-lisp (object type)
2009-06-22 tobias
136
(declare (optimize (speed 3)))
2009-08-02 tobias
137
(let ((class (get-class type)))
10:12:41 '
138
(if (has-pointer-p object)
'
139
(if (derived-p (class-of (get-object object))
2010-04-03 tobias
140
(get-class type))
2009-04-05 tobias
141
(get-object object)
2009-08-02 tobias
142
(progn
2010-04-03 tobias
143
(cerror "Remove the old object."
12:04:39 '
144
"The object at pointer ~A is ~A but should be a ~A."
'
145
object (get-object object) type)
'
146
(remove-object object)
2009-08-02 tobias
147
(instance-to-lisp object (find-smoke-class class) type)))
10:12:41 '
148
(instance-to-lisp object (find-smoke-class class) type))))
2009-04-05 tobias
149
15:36:29 '
150
'
151
'
152
(defun class-to-lisp (stack-item type)
'
153
"Returns the Lisp representation for STACK-ITEM of type C++ class."
2009-08-02 tobias
154
(object-to-lisp (foreign-slot-value stack-item 'smoke-stack-item
2009-06-22 tobias
155
'class)
12:18:08 '
156
type))
2009-04-05 tobias
157
15:36:29 '
158
(defun type-to-lisp (stack-item type)
'
159
"Returns the Lisp representation of STACK-ITEM"
2009-06-22 tobias
160
(declare (optimize (speed 3)))
2009-04-05 tobias
161
(cond
2009-08-02 tobias
162
((void-p type) (values))
10:12:41 '
163
((class-p type) (class-to-lisp stack-item type))
'
164
(t (enum-to-lisp stack-item type))))
'
165
'
166
'
167
(defun error-no-free (object)
'
168
(error "Can not free object at ~A." object))
'
169
'
170
(defmacro define-to-lisp-translation (type-names &optional
'
171
(conversion-function-name 'identity)
'
172
(free-function-name 'error-no-free))
'
173
`(progn ,@(loop for type-name in (ensure-list type-names)
'
174
collect `(setf (gethash ,type-name *to-lisp-translations*)
'
175
(cons ',conversion-function-name
'
176
',free-function-name)))))
'
177
'
178
(defmacro define-pointer-typedef (type-names lisp-type)
'
179
(declare (ignore lisp-type))
'
180
`(progn
'
181
(define-to-lisp-translation ,type-names identity identity)))
'
182
;; not needed
'
183
;;(define-from-lisp-translation ,type-names ,lisp-type)))
'
184
'
185
(define-to-lisp-translation ("void*" "const void*" "void**"))
'
186
'
187
(define-to-lisp-translation ("char*" "const char*") foreign-string-to-lisp)