repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Don't dispatch virtual methods for builtin classes (reduces overhead).
Annotate for file src/clos.lisp
2009-04-05 tobias
1
(in-package #:smoke)
15:36:29 '
2
'
3
(declaim (inline lispify))
'
4
(defun lispify (name &optional (package nil))
'
5
"Returns the interned symbol for name in Lisp style."
'
6
(declare (string name)
'
7
(optimize (speed 3)))
'
8
(if (null package)
'
9
(values (intern (cxx-to-lisp name)))
'
10
(values (intern (cxx-to-lisp name) package))))
'
11
'
12
(defmacro define-string-transform (name documentation &body states)
'
13
"Defines a function to transform a string."
'
14
(let ((output (gensym))
'
15
(index (gensym))
'
16
(length (gensym)))
'
17
`(defun ,name (input)
'
18
,documentation
'
19
(declare (simple-string input)
'
20
(optimize (speed 3)))
2009-07-22 tobias
21
;; At least on sbcl 1.0.25.debian CONCATENATE is faster than
22:26:05 '
22
;; VECTOR-PUSH-EXTEND.
2009-04-05 tobias
23
(let ((,output "")
15:36:29 '
24
(,index 0)
'
25
(,length (length input))
'
26
(char #\Null))
'
27
(declare (base-char char))
'
28
(macrolet ((next-char ()
'
29
`(if (>= ,',index ,',length)
'
30
(return-from transform ,',output)
'
31
(progn
'
32
(setf char (aref input ,',index))
'
33
(incf ,',index))))
'
34
(go-next (tag)
'
35
`(progn (next-char)
'
36
(go ,tag)))
'
37
(append-char (char)
'
38
`(setf ,',output (concatenate 'string
'
39
,',output
'
40
(string ,char)))))
'
41
(block transform
'
42
(tagbody
'
43
(next-char) ;; Get first char
'
44
,@(reduce #'append
'
45
(mapcar #'(lambda (state)
'
46
(if (stringp (second state))
'
47
`(,(first state) . ,(cddr state))
'
48
state))
'
49
states)))))))))
'
50
'
51
'
52
(define-string-transform lisp-to-cxx
'
53
"Converts LISP-STYLE to camelCase.
2009-07-01 tobias
54
Note that (LISP-TO-CXX (CXX-TO-LIST SOME-STRING)) will not necessarily return
10:54:01 '
55
a string equal to SOME-STRING."
2009-04-05 tobias
56
(default
2009-07-01 tobias
57
"Down case, convert _ and dispatch."
2009-04-05 tobias
58
(case char
15:36:29 '
59
(#\- (go-next camel-upcase))
'
60
(#\. (go-next namespace))
'
61
(t (append-char (char-downcase char))
'
62
(go-next default))))
'
63
(camel-upcase
'
64
"Convert camelCase to lisp-style."
'
65
(append-char char)
'
66
(go-next default))
'
67
(namespace
'
68
"Convert . to ::"
'
69
(append-char #\:)
'
70
(append-char #\:)
'
71
(go default)))
'
72
'
73
(define-string-transform cxx-to-lisp
2009-04-17 tobias
74
"Returns camelCase STRING in lisp-style."
2009-04-05 tobias
75
(begin
2009-07-01 tobias
76
"Strip leading Q or K."
2009-04-05 tobias
77
(case char
15:36:29 '
78
(#\K (go-next default))
'
79
(#\Q (go-next default))
'
80
(t (go default))))
'
81
(default
2009-07-01 tobias
82
"Up case, convert _ and dispatch."
2009-04-05 tobias
83
(case char
15:36:29 '
84
(#\: (go-next namespace))
'
85
(#\_ (append-char #\-)
'
86
(go-next default))
2009-04-17 tobias
87
(#\ (append-char #\-) ;; space (cast operators)
15:26:55 '
88
(go-next default))
2009-04-05 tobias
89
(t (append-char (char-upcase char))
15:36:29 '
90
(if (lower-case-p char)
'
91
(go-next camel-case)
'
92
(go-next default)))))
'
93
(namespace
2009-06-22 tobias
94
"C++ namespace separator"
2009-04-05 tobias
95
(assert (eql #\: char))
15:36:29 '
96
(append-char #\.)
'
97
(go-next default))
'
98
(camel-case
'
99
"Convert camelCase to lisp-style."
'
100
(if (upper-case-p char)
'
101
(progn
'
102
(append-char #\-)
'
103
(append-char char)
'
104
(go-next default))
'
105
(go default))))
'
106
'
107
'
108
(defmethod print-object ((object smoke-standard-object) stream)
2009-05-27 tobias
109
(if (slot-boundp object 'pointer)
17:22:08 '
110
(print-unreadable-object (object stream :type t)
2009-08-27 tobias
111
(when (const-p object)
11:43:13 '
112
(princ "CONST " stream))
2009-05-27 tobias
113
(princ (pointer object) stream))
17:22:08 '
114
(call-next-method)))
2009-04-05 tobias
115
15:36:29 '
116
(defclass smoke-standard-class (standard-class smoke-class)
2009-05-24 tobias
117
()
2009-04-05 tobias
118
(:documentation "A Smoke C++ class"))
15:36:29 '
119
2009-05-31 tobias
120
(defclass cxx:class (smoke-standard-class)
2009-07-08 tobias
121
()
2009-05-31 tobias
122
(:documentation "Metaclass to extend Smoke Objects."))
2009-05-14 tobias
123
2009-08-30 tobias
124
(defclass smoke-multi-superclass-mixin ()
14:12:44 '
125
((extra-objects :reader extra-objects
'
126
:initarg :extra-objects)))
'
127
2009-08-02 tobias
128
(defmethod closer-mop:validate-superclass ((class smoke-standard-class)
10:12:41 '
129
(superclass standard-class))
2009-07-22 tobias
130
t)
2009-04-05 tobias
131
2009-08-02 tobias
132
(defmethod closer-mop:validate-superclass ((class cxx:class)
10:12:41 '
133
(superclass smoke-standard-class))
2009-07-22 tobias
134
t)
2009-04-05 tobias
135
2009-08-02 tobias
136
;; Sets NIL superclass to SMOKE-STANDARD-OBJECT instead of the default
10:12:41 '
137
;; STANDARD-OBJECT.
'
138
(defun init-smoke-standard-class (class next-method
'
139
&rest args &key direct-superclasses
'
140
&allow-other-keys)
'
141
(apply next-method class
'
142
:direct-superclasses (or direct-superclasses
'
143
(list (find-class 'smoke-standard-object)))
'
144
args))
2009-04-05 tobias
145
2009-08-02 tobias
146
(defmethod initialize-instance :around ((class smoke-standard-class) &rest args)
10:12:41 '
147
(apply #'init-smoke-standard-class class #'call-next-method args))
'
148
'
149
(defmethod reinitialize-instance :around ((class smoke-standard-class) &rest args)
'
150
(apply #'init-smoke-standard-class class #'call-next-method args))
2009-04-05 tobias
151
15:36:29 '
152
2009-08-02 tobias
153
(defun init-cxx-class (class next-method &rest args &key direct-superclasses
2009-08-30 tobias
154
direct-default-initargs &allow-other-keys)
2009-04-05 tobias
155
(assert (not (null direct-superclasses))
15:36:29 '
156
(direct-superclasses)
2009-08-30 tobias
157
"No superclass supplied for class ~A" class)
14:12:44 '
158
(let ((superclass (first direct-superclasses))
'
159
(extra-superclasses (remove-if-not #'(lambda (class)
'
160
(typep class 'smoke-standard-class))
'
161
(rest direct-superclasses))))
'
162
(assert (typep superclass 'smoke-standard-class)
2009-04-05 tobias
163
((first direct-superclasses))
2009-08-30 tobias
164
"The first superclass ~A must be an subclass of an Smoke class."
14:12:44 '
165
class)
2009-06-10 tobias
166
(assert (virtual-destructor-p superclass)
11:55:55 '
167
()
2009-08-30 tobias
168
"The superclass ~A of ~A has a non virtual destructor."
14:12:44 '
169
superclass class)
'
170
(when extra-superclasses
'
171
(dolist (superclass extra-superclasses)
'
172
(unless (virtual-destructor-p superclass)
'
173
(cerror "Continue anyway"
'
174
"The superclass ~A of ~A has a non virtual destructor."
'
175
superclass class)))
'
176
(setf direct-superclasses
'
177
(append direct-superclasses
'
178
(list (find-class 'smoke-multi-superclass-mixin))))
'
179
(push `(:extra-objects ,extra-superclasses ,#'(lambda ()
'
180
extra-superclasses))
'
181
direct-default-initargs))
2009-04-05 tobias
182
(apply
2009-08-02 tobias
183
next-method class
2009-07-08 tobias
184
:id (id superclass)
2009-06-22 tobias
185
:smoke (smoke superclass)
2009-04-05 tobias
186
:direct-superclasses direct-superclasses
2009-08-30 tobias
187
:direct-default-initargs direct-default-initargs
2009-04-05 tobias
188
args)))
15:36:29 '
189
2009-08-02 tobias
190
(defmethod reinitialize-instance :around ((class cxx:class) &rest args)
10:12:41 '
191
(apply #'init-cxx-class class #'call-next-method args))
'
192
'
193
(defmethod initialize-instance :around ((class cxx:class) &rest args)
'
194
(apply #'init-cxx-class class #'call-next-method args))
'
195
2010-01-26 tobias
196
(defun smoke-class-symbols (classes)
16:26:09 '
197
(let ((class-symbols))
'
198
(dolist (class classes class-symbols)
'
199
(if (external-p class)
'
200
(let ((real-class (find-smoke-class class nil)))
2010-01-30 tobias
201
(when real-class
14:40:08 '
202
(push (class-name real-class) class-symbols)))
2010-01-26 tobias
203
(push (lispify (name class)) class-symbols)))))
2009-04-05 tobias
204
2009-06-11 tobias
205
(defun make-smoke-classes (package smoke)
2009-07-01 tobias
206
"Constructs a lisp class in PACKAGE for each one in the Smoke module SMOKE."
2009-06-22 tobias
207
(declare (optimize (speed 3)))
2010-01-10 tobias
208
(let ((impl-package *package*)
08:49:36 '
209
(*package* (find-package package)))
2009-06-22 tobias
210
(add-id-class-map smoke)
2009-04-05 tobias
211
(map-classes
15:36:29 '
212
#'(lambda (class)
2010-01-10 tobias
213
(unless (external-p class)
2009-08-27 tobias
214
(with-simple-restart (skip "Skip generating class ~A" (name class))
2010-01-10 tobias
215
(let ((class-name
08:49:36 '
216
;; There is a QGlobalSpace class per Smoke module.
'
217
;; Put it in *package* and not PACKAGE to avoid
'
218
;; clashes between multiple modules.
'
219
(if (string= "QGlobalSpace" (name class))
'
220
(lispify "QGlobalSpace" impl-package)
'
221
(lispify (name class)))))
'
222
(add-id class
'
223
(closer-mop:ensure-class class-name
'
224
:direct-superclasses
2010-01-26 tobias
225
(smoke-class-symbols
16:26:09 '
226
(smoke-class-direct-superclasses class))
2010-01-10 tobias
227
:id (id class)
08:49:36 '
228
:smoke (smoke class)
'
229
:metaclass 'smoke-standard-class))
'
230
(when (eql (symbol-package class-name) *package*)
'
231
(export class-name))))))
2009-06-11 tobias
232
smoke)))
2009-04-05 tobias
233
2009-04-12 tobias
234
(defclass smoke-gf (cxx-generic-function)
14:43:33 '
235
((cxx-name :reader name :initarg :cxx-name
2009-05-11 tobias
236
:type string
11:07:39 '
237
:documentation "The C++ name of the method."))
2009-04-05 tobias
238
(:metaclass closer-mop:funcallable-standard-class)
2009-05-11 tobias
239
(:documentation "Smoke generic function."))
2009-04-05 tobias
240
2009-06-22 tobias
241
(declaim (inline smoke-class-of))
2009-04-05 tobias
242
(defun smoke-class-of (object)
2009-07-01 tobias
243
"Returns the class of OBJECT or OBJECT iff it already is a class."
2009-06-22 tobias
244
(declare (optimize (speed 3)))
12:18:08 '
245
(if (typep object 'smoke-class)
2009-04-05 tobias
246
object
15:36:29 '
247
(class-of object)))
'
248
2009-04-12 tobias
249
;;; To speed up the startup
2009-04-05 tobias
250
;;; ENSURE-METHOD is only called as needed.
15:36:29 '
251
(defmethod no-applicable-method ((gf smoke-gf) &rest args)
'
252
"Calls the smoke method."
2009-06-22 tobias
253
(declare (dynamic-extent args)
12:18:08 '
254
(optimize (speed 3)))
2009-04-17 tobias
255
(call-using-args (first args) (name gf) (rest args)))
2009-04-05 tobias
256
2009-04-12 tobias
257
(defmethod add-method :after ((gf cxx-method-generic-function) method)
2009-04-05 tobias
258
"Adds a method which calls the smoke method, to make call-next-method work."
15:36:29 '
259
(when (null (rest (closer-mop:generic-function-methods gf)))
2009-04-12 tobias
260
(let ((lambda-list (closer-mop:method-lambda-list method)))
14:43:33 '
261
(closer-mop:ensure-method
'
262
gf
'
263
`(lambda ,lambda-list
'
264
(declare (optimize (speed 3)))
2009-05-11 tobias
265
(call-using-args ,(first lambda-list)
17:55:42 '
266
(name ,(cxx-generic-function gf))
2009-05-11 tobias
267
(list ,@(rest lambda-list))))))))
2009-04-05 tobias
268
15:36:29 '
269
(defcallback destructed :void
2009-07-22 tobias
270
((object-pointer :pointer))
2009-06-22 tobias
271
(declare (optimize (speed 3)))
2009-04-05 tobias
272
(let ((object (get-object object-pointer)))
2009-08-02 tobias
273
;; The destructed callback can be the result of deleting the object
10:12:41 '
274
;; in a finalizer. In that case the object is already removed from
'
275
;; *object-map* when the callback is invoked. Thus OBJECT can be NIL.
2009-04-05 tobias
276
(when object
2009-09-02 tobias
277
(when (typep object 'smoke-multi-superclass-mixin)
11:49:34 '
278
(dolist (extra-object (extra-objects object))
'
279
(unless (null-pointer-p (pointer extra-object))
'
280
(remove-object (pointer extra-object))
'
281
(delete-object extra-object))))
2009-06-30 tobias
282
(remove-finalizer object)
2009-04-05 tobias
283
(remove-object object-pointer)
15:36:29 '
284
(setf (slot-value object 'pointer) (null-pointer)))))
'
285
2009-06-22 tobias
286
(declaim (inline argument-to-lisp))
12:18:08 '
287
(defun argument-to-lisp (stack-item type)
'
288
;; FIXME do not take ownership of stack allocated objects.
2009-08-02 tobias
289
;; It looks like there is no stack allocation in Qt virtual method signatures.
2009-06-22 tobias
290
(type-to-lisp stack-item type))
12:18:08 '
291
2009-04-05 tobias
292
(defun stack-to-args (stack arg &optional (args nil))
15:36:29 '
293
"Returns the arguments in STACK, where ARG is the type
'
294
of the first argument, as an list of Lisp objects."
'
295
(if (end-p arg)
2009-06-22 tobias
296
(reverse args)
12:18:08 '
297
(stack-to-args (inc-pointer stack
'
298
(foreign-type-size 'smoke-stack-item))
2009-04-05 tobias
299
(next arg)
2009-08-27 tobias
300
(cons (argument-to-lisp (mem-ref stack 'smoke-stack-item)
2009-07-22 tobias
301
arg)
2009-06-22 tobias
302
args))))
2009-04-05 tobias
303
2009-09-02 tobias
304
(defun convert-argument (argument type &optional disown)
11:49:34 '
305
"Returns ARGUMENT converted to TYPE and removes the ownership when
'
306
it is passed on the stack."
'
307
(flet ((disown (object)
'
308
(remove-finalizer object)
'
309
(when (typep object 'smoke-standard-object)
'
310
(remove-object (pointer object)))))
'
311
(let ((rank (get-conversion-sequence argument type nil)))
'
312
(if (null rank)
'
313
(let ((rank (get-conversion-sequence argument type t)))
'
314
(if (null rank)
'
315
(error "Can not convert the argument ~S to ~A."
'
316
argument (name type))
'
317
(let ((ret (funcall (conversion-function-name rank)
'
318
argument)))
'
319
(when (and disown (stack-p type))
'
320
(disown ret))
'
321
ret)))
'
322
(prog1 (funcall (conversion-function-name rank) argument)
'
323
(when (and disown (stack-p type))
'
324
(disown argument)))))))
2009-04-05 tobias
325
2009-06-08 tobias
326
(defun put-returnvalue (stack value type object)
2009-04-05 tobias
327
(unless (void-p type)
2009-05-26 tobias
328
(let ((stack (make-call-stack stack)))
2009-07-08 tobias
329
(setf (call-stack-top stack) (call-stack-pointer stack))
2009-09-02 tobias
330
(let ((converted-value (convert-argument value type t)))
11:49:34 '
331
(push-smoke-stack stack converted-value (type-id type))))))
2009-04-05 tobias
332
2009-05-19 tobias
333
(defun get-gf-for-method (smoke-method)
11:09:12 '
334
(declare (smoke-method smoke-method)
'
335
(optimize (speed 3)))
'
336
(symbol-function (lispify (name smoke-method) "CXX")))
2009-05-19 tobias
337
2009-08-30 tobias
338
;; Receive virtual function calls.
2009-04-05 tobias
339
(defcallback dispatch-method :boolean
2010-02-19 tobias
340
((binding :pointer)
21:10:24 '
341
(method smoke-index)
2009-06-30 tobias
342
(object-ptr :pointer)
22:47:39 '
343
(stack smoke-stack)
'
344
(abstract :boolean))
2009-04-05 tobias
345
(declare (optimize (speed 3)))
2009-06-30 tobias
346
(let ((object (get-object object-ptr)))
2009-08-02 tobias
347
;; The Lisp OBJECT can be gc'ed but we might still receive a
10:12:41 '
348
;; QObject destructed event when the C++ instance is deleted in
'
349
;; the finalizer. Thus OBJECT might be NIL.
2010-02-18 tobias
350
(unless (null object)
2009-08-02 tobias
351
(let* ((method (make-smoke-method
2010-02-19 tobias
352
:smoke (gethash (pointer-address
21:10:24 '
353
(smoke-get-smoke binding))
'
354
*smoke-modules*)
2009-08-02 tobias
355
:id method)))
10:12:41 '
356
(loop
'
357
(restart-case
'
358
(return-from dispatch-method
'
359
(let ((gf (get-gf-for-method method)))
'
360
(declare (function gf))
'
361
(if (null (gf-methods gf))
'
362
(progn
'
363
(when abstract
'
364
(error "Abstract method ~A of ~A called."
'
365
(method-declaration method) object))
'
366
nil)
'
367
(if object
'
368
(progn
'
369
(put-returnvalue
'
370
stack
'
371
(apply gf object
'
372
(stack-to-args
'
373
(inc-pointer stack (foreign-type-size
'
374
'smoke-stack-item))
'
375
(get-first-argument method)))
'
376
(return-type method) object)
'
377
t)
'
378
nil))))
'
379
;; Restarts to prevent stack unwinding across the C++ stack.
'
380
(call-default ()
'
381
:report (lambda (stream)
'
382
(declare (stream stream))
'
383
(format stream
'
384
"Call default implementation ~A instead."
'
385
method))
'
386
:test (lambda (condition)
'
387
(declare (ignore condition))
'
388
(not abstract))
'
389
(return-from dispatch-method nil))
'
390
(use-returnvalue (return-value)
'
391
:report (lambda (stream)
'
392
(declare (stream stream))
'
393
(format stream "Supply a return value for ~A."
'
394
(method-declaration method)))
'
395
:test (lambda (condition)
'
396
(declare (ignore condition))
'
397
(not (void-p (return-type method))))
'
398
:interactive (lambda ()
'
399
(format *query-io* "~&Enter a new return value: ")
'
400
(multiple-value-list (eval (read *query-io*))))
'
401
(put-returnvalue stack return-value
'
402
(return-type method)
'
403
(get-object object-ptr))
'
404
(return-from dispatch-method t))
'
405
(return ()
'
406
:report (lambda (stream)
'
407
(declare (stream stream))
'
408
(format stream "Return void for ~A."
'
409
(method-declaration method)))
'
410
:test (lambda (condition)
'
411
(declare (ignore condition))
'
412
(void-p (return-type method)))
'
413
(return-from dispatch-method (values)))
'
414
(retry ()
'
415
:report (lambda (stream)
'
416
(declare (stream stream))
'
417
(format stream "Try again calling ~A."
'
418
(method-declaration method))))))
'
419
nil))))
2009-04-05 tobias
420
15:36:29 '
421
;;FIXME use CHANGE-CLASS instead?
2009-08-30 tobias
422
(defgeneric cast (object class)
2009-07-08 tobias
423
(declare (optimize (speed 3)))
2009-08-30 tobias
424
(:documentation "Returns a pointer of type CLASS to the C++ object of OBJECT.")
14:12:44 '
425
(:method (object class)
'
426
(declare (optimize (speed 3)))
'
427
(assert (derived-p (class-of object) class)
'
428
()
'
429
"Can not cast object ~A of class ~A to class ~A."
'
430
object (name (class-of object)) (name class))
'
431
(smoke-cast (smoke-module-pointer (smoke (class-of object))) (pointer object)
2010-02-18 tobias
432
(id (class-of object))
18:31:47 '
433
(smoke-class-id (smoke-module-pointer (smoke (class-of object)))
'
434
(name-pointer class))))
2009-08-30 tobias
435
(:method ((object smoke-multi-superclass-mixin) class)
14:12:44 '
436
(if (derived-p (class-of object) class)
'
437
(call-next-method)
'
438
(let ((extra-object (find-if #'(lambda (o)
'
439
(derived-p (class-of o) class))
'
440
(extra-objects object))))
'
441
(assert extra-object
'
442
()
'
443
"Can not cast object ~A to class ~A."
'
444
object (name class))
'
445
(cast extra-object class)))))
2009-04-05 tobias
446
15:36:29 '
447
(defun upcast (object class)
'
448
(assert (derived-p class (class-of object))
'
449
()
'
450
"Can not upcast object ~A of class ~A to class ~A."
'
451
object (name (class-of object)) (name class))
2009-06-22 tobias
452
(smoke-cast (smoke-module-pointer (smoke class)) (pointer object)
2009-04-05 tobias
453
(id (class-of object)) (id (real-class class))))
15:36:29 '
454
'
455
2009-08-02 tobias
456
;; The constructor name is the name of the class minus any namespace parts.
2009-07-22 tobias
457
(defun constructor-name (class)
2010-02-19 tobias
458
(let ((name-start (search "::" (name class) :from-end t)))
2009-07-22 tobias
459
(if name-start
2010-02-19 tobias
460
(subseq (name class) (+ name-start 2))
21:22:50 '
461
(name class))))
2009-07-22 tobias
462
2009-08-30 tobias
463
(defun call-constructor (class arguments)
14:12:44 '
464
(multiple-value-bind (method sequence)
2010-02-20 tobias
465
(find-best-viable-function (constructor-name class)
17:24:36 '
466
arguments
'
467
class)
2009-08-30 tobias
468
(when (null method)
14:12:44 '
469
(error "No constructor for class ~A with
'
470
the arguments ~S." class arguments))
'
471
(pointer-call method (null-pointer)
'
472
(mapcar #'(lambda (conversion argument)
'
473
(funcall conversion argument))
'
474
sequence arguments))))
2009-04-05 tobias
475
15:36:29 '
476
(defmethod initialize-instance :after ((object smoke-standard-object)
2009-07-22 tobias
477
&key args
22:26:05 '
478
(arg0 nil arg0p)
'
479
(arg1 nil arg1p)
'
480
(arg2 nil arg2p)
2010-01-25 tobias
481
(arg3 nil arg3p)
2009-07-22 tobias
482
&allow-other-keys)
2009-04-05 tobias
483
"Initializes a Smoke object. Calls its constructor with the arguments supplied
15:36:29 '
484
by the key :ARGS and sets the smoke binding."
2009-06-22 tobias
485
(declare (optimize (speed 3)))
2009-04-05 tobias
486
(assert (not (and (slot-boundp object 'pointer)
15:36:29 '
487
(not (null args))))
'
488
((slot-value object 'pointer) args)
'
489
"Pointer ~A bound and constructor argument :ARGS ~S supplied."
'
490
(slot-value object 'pointer) args)
'
491
(unless (slot-boundp object 'pointer)
2009-07-22 tobias
492
(if arg0p
22:26:05 '
493
(setf (slot-value object 'pointer)
2009-08-30 tobias
494
(call-constructor (class-of object)
2009-07-22 tobias
495
(cond
2010-01-25 tobias
496
(arg3p (list arg0 arg1 arg2 arg3))
2009-07-22 tobias
497
(arg2p (list arg0 arg1 arg2))
22:26:05 '
498
(arg1p (list arg0 arg1))
'
499
(t (list arg0)))))
2009-08-30 tobias
500
(setf (slot-value object 'pointer)
14:12:44 '
501
(call-constructor (class-of object) args)))
2009-06-22 tobias
502
(set-binding object)
2009-05-24 tobias
503
(take-ownership object)
2009-04-05 tobias
504
(add-object object)))
15:36:29 '
505
2009-08-30 tobias
506
(defun construct-extra-objects (object extra-objects)
14:12:44 '
507
(loop for class in extra-objects
'
508
collect (let ((extra-object (make-instance (first extra-objects)
'
509
:pointer (call-constructor (first extra-objects)
'
510
nil))))
'
511
(set-binding extra-object)
'
512
(setf (get-object (pointer extra-object)) object)
'
513
extra-object)))
'
514
'
515
(defmethod initialize-instance :after ((object smoke-multi-superclass-mixin)
'
516
&key args)
'
517
(setf (slot-value object 'extra-objects)
'
518
(construct-extra-objects object (extra-objects object))))
'
519
'
520
(defmethod make-finalize ((object smoke-multi-superclass-mixin))
'
521
(let ((pointer (pointer object))
'
522
(extra-objects (extra-objects object))
'
523
(class (class-of object)))
'
524
#'(lambda ()
'
525
(declare (optimize (speed 3)))
'
526
(handler-case (progn
'
527
(delete-pointer pointer class)
'
528
(dolist (object extra-objects)
'
529
(delete-object object)))
'
530
(error (condition)
'
531
(report-finalize-error condition 't (name class) pointer))))))
2009-04-05 tobias
532
15:36:29 '
533
(defmethod instance-to-lisp (pointer class type)
2009-06-22 tobias
534
(declare (type smoke-standard-class class)
12:18:08 '
535
(optimize (speed 3)))
2009-08-27 tobias
536
(let ((ret (make-instance class :pointer pointer
11:43:13 '
537
:const-p (const-p type))))
2009-05-24 tobias
538
(when (stack-p type)
11:30:05 '
539
(take-ownership ret)
'
540
(add-object ret))
2009-04-05 tobias
541
ret))
2009-05-31 tobias
542
2009-06-08 tobias
543
(defun keep-wrapper (object new-owner)
2009-06-22 tobias
544
(declare (type smoke-standard-object object)
12:18:08 '
545
(optimize (speed 3)))
2009-06-10 tobias
546
(when (member object (owned-objects new-owner))
2009-08-30 tobias
547
(cerror "Ignore" "~A has already been added to ~A."
2009-08-02 tobias
548
object new-owner))
2009-06-08 tobias
549
(push object (owned-objects new-owner)))
2009-05-31 tobias
550
2009-06-22 tobias
551
(declaim (inline remove-wrapper-object))
2009-06-08 tobias
552
(defun remove-wrapper-object (object owner)
09:20:54 '
553
(remove object (owned-objects owner)))
2009-05-31 tobias
554
2009-06-08 tobias
555
(defun transfer-ownership-to (object new-owner)
2009-05-31 tobias
556
"Transfers the ownership of OBJECT to C++."
2009-06-22 tobias
557
(declare (optimize (speed 3)))
2009-06-30 tobias
558
(remove-finalizer object)
2009-06-10 tobias
559
(if (virtual-destructor-p (class-of object))
11:55:55 '
560
(keep-wrapper object new-owner)
'
561
(remove-object (pointer object))))
2009-05-31 tobias
562
2009-06-08 tobias
563
(defun take-ownership (object &optional current-owner)
2009-05-31 tobias
564
"Assigns the ownership of OBJECT to Lisp. i.e.:
17:41:26 '
565
cl-smoke is responsible for deleting the object."
2009-06-08 tobias
566
(when current-owner
09:20:54 '
567
(remove-wrapper-object object current-owner))
2009-06-30 tobias
568
(set-finalizer object))