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