repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Improve missing to-lisp-translator error message.
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 (if-let ((translation (gethash (name type) *to-lisp-translations*)))
19:25:37 '
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))))
2010-01-23 tobias
114
(prog1 (foreign-slot-value stack-item 'smoke-stack-item 'voidp)
2010-03-10 tobias
115
(cerror "Return the pointer"
16:38:58 '
116
"Missing type translator to convert the type ~A to Lisp."
'
117
type))))
2009-04-05 tobias
118
(1 (foreign-slot-value stack-item 'smoke-stack-item 'bool))
15:36:29 '
119
(2 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'char)))
'
120
(3 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'uchar)))
'
121
(4 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'short)))
'
122
(5 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'ushort)))
'
123
(6 (foreign-slot-value stack-item 'smoke-stack-item 'int))
'
124
(7 (foreign-slot-value stack-item 'smoke-stack-item 'uint))
'
125
(8 (foreign-slot-value stack-item 'smoke-stack-item 'long))
'
126
(9 (foreign-slot-value stack-item 'smoke-stack-item 'ulong))
'
127
(10 (foreign-slot-value stack-item 'smoke-stack-item 'float))
'
128
(11 (foreign-slot-value stack-item 'smoke-stack-item 'double))
'
129
(12 (make-instance 'enum
2009-08-02 tobias
130
:value (foreign-slot-value stack-item 'smoke-stack-item
10:12:41 '
131
'enum-value)
2009-04-05 tobias
132
:type type))))
15:36:29 '
133
'
134
(defgeneric instance-to-lisp (pointer class type)
2009-06-22 tobias
135
(declare (optimize (speed 3)))
2009-07-01 tobias
136
(:documentation "Returns a CLOS instance for POINTER."))
2009-04-05 tobias
137
15:36:29 '
138
(defun object-to-lisp (object type)
2009-06-22 tobias
139
(declare (optimize (speed 3)))
2009-08-02 tobias
140
(let ((class (get-class type)))
10:12:41 '
141
(if (has-pointer-p object)
'
142
(if (derived-p (class-of (get-object object))
2010-04-03 tobias
143
(get-class type))
2009-04-05 tobias
144
(get-object object)
2009-08-02 tobias
145
(progn
2010-04-03 tobias
146
(cerror "Remove the old object."
12:04:39 '
147
"The object at pointer ~A is ~A but should be a ~A."
'
148
object (get-object object) type)
'
149
(remove-object object)
2009-08-02 tobias
150
(instance-to-lisp object (find-smoke-class class) type)))
10:12:41 '
151
(instance-to-lisp object (find-smoke-class class) type))))
2009-04-05 tobias
152
15:36:29 '
153
'
154
'
155
(defun class-to-lisp (stack-item type)
'
156
"Returns the Lisp representation for STACK-ITEM of type C++ class."
2009-08-02 tobias
157
(object-to-lisp (foreign-slot-value stack-item 'smoke-stack-item
2009-06-22 tobias
158
'class)
12:18:08 '
159
type))
2009-04-05 tobias
160
15:36:29 '
161
(defun type-to-lisp (stack-item type)
'
162
"Returns the Lisp representation of STACK-ITEM"
2009-06-22 tobias
163
(declare (optimize (speed 3)))
2009-04-05 tobias
164
(cond
2009-08-02 tobias
165
((void-p type) (values))
10:12:41 '
166
((class-p type) (class-to-lisp stack-item type))
'
167
(t (enum-to-lisp stack-item type))))
'
168
'
169
'
170
(defun error-no-free (object)
'
171
(error "Can not free object at ~A." object))
'
172
'
173
(defmacro define-to-lisp-translation (type-names &optional
'
174
(conversion-function-name 'identity)
'
175
(free-function-name 'error-no-free))
'
176
`(progn ,@(loop for type-name in (ensure-list type-names)
'
177
collect `(setf (gethash ,type-name *to-lisp-translations*)
'
178
(cons ',conversion-function-name
'
179
',free-function-name)))))
'
180
'
181
(defmacro define-pointer-typedef (type-names lisp-type)
'
182
(declare (ignore lisp-type))
'
183
`(progn
'
184
(define-to-lisp-translation ,type-names identity identity)))
'
185
;; not needed
'
186
;;(define-from-lisp-translation ,type-names ,lisp-type)))
'
187
'
188
(define-to-lisp-translation ("void*" "const void*" "void**"))
'
189
'
190
(define-to-lisp-translation ("char*" "const char*") foreign-string-to-lisp)