repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Cache overload resolution on sbcl
Annotate for file src/overload-resolution.lisp
2009-04-17 tobias
1
;;; C++ overload resolution
15:26:55 '
2
;;; See: http://www.open-std.org/jtc1/sc22/wg21/docs/papers/2008/n2800.pdf
2009-08-27 tobias
3
;;;
11:43:13 '
4
;;; We handle only the most common cases. Stuff like virtual inheritance
'
5
;;; that is not needed is not implemented.
2009-04-17 tobias
6
15:26:55 '
7
(in-package :smoke)
'
8
2009-06-22 tobias
9
(declaim (inline cmp))
12:18:08 '
10
(defun cmp (a b)
2009-07-22 tobias
11
(- a b))
2009-06-22 tobias
12
2009-07-22 tobias
13
(declaim (inline strcmp))
22:26:05 '
14
(defcfun strcmp :int (s1 :pointer) (s2 :pointer))
2009-04-17 tobias
15
2009-07-22 tobias
16
(declaim (inline cstring/=))
2009-06-22 tobias
17
(defun cstring/= (string1 string2)
12:18:08 '
18
"Returns T when the C strings STRING1 and STRING2 are not equal
'
19
and NIL otherwise."
2009-07-22 tobias
20
(not (zerop (strcmp string1 string2))))
2009-04-17 tobias
21
2009-06-22 tobias
22
(defun method-cmp (method class-id name)
12:18:08 '
23
"Compares METHOD to the method with NAME of class CLASS-ID."
'
24
(declare (foreign-pointer name)
'
25
(type (smoke-index 0) class-id)
'
26
(smoke-method method)
'
27
(optimize (speed 3) (debug 0) (safety 0)))
'
28
(let ((id-cmp (cmp (the (smoke-index 0) (method-slot-value method 'class))
'
29
(the (smoke-index 0) class-id))))
2009-07-22 tobias
30
(declare (type smoke-index id-cmp))
2009-06-22 tobias
31
(if (/= 0 id-cmp)
12:18:08 '
32
id-cmp
2009-07-22 tobias
33
(strcmp (smoke-method-name method)
2009-06-22 tobias
34
name))))
12:18:08 '
35
2009-07-08 tobias
36
(declaim (inline first-unabigious-index))
2009-06-22 tobias
37
(defun first-unabigious-index (smoke index)
12:18:08 '
38
(declare (type smoke-index index)
2009-04-17 tobias
39
(optimize (speed 3)))
2009-06-22 tobias
40
(if (>= index 0)
12:18:08 '
41
index
'
42
(mem-aref (smoke-module-ambiguous-method-list smoke)
'
43
'smoke-index
'
44
(- index))))
2009-04-17 tobias
45
2009-06-22 tobias
46
(defun find-method-for-class (name class)
12:18:08 '
47
"Returns the index of a method with name NAME for class CLASS."
'
48
(declare (type foreign-pointer name)
'
49
(type smoke-class class)
'
50
(optimize (speed 3)))
'
51
(let* ((start 1) ;; 0 is "no method"
2009-06-30 tobias
52
(class-id (id class))
22:47:39 '
53
(smoke (smoke class))
2009-07-03 tobias
54
(end (1+ (smoke-array-length (smoke-module-method-maps smoke)))))
2009-07-08 tobias
55
(declare (type (smoke-index 0) start end)
20:41:19 '
56
(dynamic-extent start))
2009-06-22 tobias
57
(loop until (> start end) do
12:18:08 '
58
(let* ((index (the smoke-index (floor (+ end start) 2)))
'
59
(method (make-smoke-method
'
60
:smoke smoke
'
61
:id (the (smoke-index 0)
'
62
(first-unabigious-index
'
63
smoke
'
64
(foreign-slot-value
'
65
(mem-aref (smoke-array-pointer
'
66
(smoke-module-method-maps
'
67
smoke))
'
68
'smoke-method-map index)
'
69
'smoke-method-map
'
70
'method)))))
2009-07-22 tobias
71
(cmp (the smoke-index (method-cmp method class-id name))))
22:26:05 '
72
(declare (type smoke-index cmp)
2009-07-08 tobias
73
(dynamic-extent method))
2009-07-22 tobias
74
(if (< cmp 0)
22:26:05 '
75
(setf start (1+ index))
'
76
(if (> cmp 0)
'
77
(setf end (1- index))
'
78
(return-from find-method-for-class index))))))
2009-06-22 tobias
79
-1)
2009-04-17 tobias
80
2009-08-27 tobias
81
(defmacro push-candidate-method (index name argument-count class methods
11:43:13 '
82
const-p)
2009-06-22 tobias
83
(with-gensyms (method-map method-index method ambig-index i smoke)
12:18:08 '
84
`(let* ((,smoke (smoke ,class))
'
85
(,method-map (mem-aref
'
86
(smoke-array-pointer
'
87
(smoke-module-method-maps ,smoke))
'
88
'smoke-method-map
2009-07-22 tobias
89
(the smoke-index ,index)))
2009-06-22 tobias
90
(,method-index (foreign-slot-value ,method-map 'smoke-method-map 'method))
12:18:08 '
91
(,method (make-smoke-method
'
92
:smoke ,smoke
'
93
:id (first-unabigious-index
'
94
,smoke
'
95
,method-index))))
'
96
(declare (type smoke-index ,method-index))
'
97
(if (cstring/= ,name
'
98
(smoke-method-name ,method))
'
99
nil
'
100
(progn
'
101
(when (= (the smoke-index ,argument-count)
'
102
(the smoke-index (get-arguments-length ,method)))
'
103
(if (< ,method-index 0)
'
104
(let ((,ambig-index (- ,method-index)))
'
105
(declare (type smoke-index ,ambig-index))
'
106
(loop as ,i = (the smoke-index
'
107
(mem-aref (smoke-module-ambiguous-method-list
'
108
,smoke)
'
109
'smoke-index
'
110
,ambig-index))
'
111
while (> (the smoke-index ,i) 0) do
2009-08-27 tobias
112
(incf ,ambig-index)
11:43:13 '
113
(let ((,method (make-smoke-method :smoke ,smoke
'
114
:id ,i)))
'
115
(unless (and ,const-p (not (const-p ,method)))
'
116
(push ,method ,methods)))))
'
117
(unless (and ,const-p (not (const-p ,method)))
'
118
(push ,method ,methods))))
2009-06-22 tobias
119
t)))))
2009-05-11 tobias
120
2009-08-27 tobias
121
(defun viable-functions (name argument-count class &optional const-p)
2009-06-22 tobias
122
(declare (optimize (speed 3)))
12:18:08 '
123
(with-foreign-string (name name)
2009-07-22 tobias
124
(let ((methods))
2009-08-27 tobias
125
(let ((smoke (smoke class)))
11:43:13 '
126
(let ((start-index (find-method-for-class name class)))
'
127
(declare (type smoke-index start-index))
'
128
(when (>= start-index 0)
'
129
(loop for index from start-index downto 1
'
130
while (push-candidate-method index name argument-count class
'
131
methods const-p))
'
132
(loop for index from (1+ start-index)
'
133
to (the smoke-index (smoke-array-length
'
134
(smoke-module-method-maps smoke)))
'
135
while (push-candidate-method index name argument-count class
'
136
methods const-p)))))
2009-06-22 tobias
137
methods)))
12:18:08 '
138
2009-07-08 tobias
139
(declaim (inline make-conversion make-exact-match make-promotion
20:41:19 '
140
make-number-conversion make-pointer-conversion
'
141
make-boolean-conversion make-user-conversion))
'
142
(defstruct conversion
2009-09-01 tobias
143
(function-name nil :type (or symbol list function) :read-only t)
2009-07-08 tobias
144
(rank -1 :type fixnum :read-only t))
2009-04-17 tobias
145
2009-07-22 tobias
146
(defstruct (exact-match (:include conversion (rank 0))))
2009-04-17 tobias
147
2009-07-22 tobias
148
(defstruct (promotion (:include conversion (rank 1))))
2009-04-17 tobias
149
2009-07-22 tobias
150
(defstruct (number-conversion (:include conversion (rank 2))))
2009-04-17 tobias
151
2009-07-22 tobias
152
(defstruct (pointer-conversion (:include conversion (rank 3)))
2009-07-08 tobias
153
(from (find-class t) :type class :read-only t)
20:41:19 '
154
(to (find-class t) :type class :read-only t))
2009-04-17 tobias
155
2009-07-22 tobias
156
(defstruct (boolean-conversion (:include conversion (rank 4))))
2009-04-17 tobias
157
2009-07-22 tobias
158
(defstruct (user-conversion (:include conversion (rank 5))))
2009-04-17 tobias
159
2009-08-27 tobias
160
(defgeneric conversion<= (conversion1 conversion2)
2009-04-17 tobias
161
;; 13.3.3.2 Ranking implicit conversion sequences
15:26:55 '
162
;; 4
'
163
(:method (conversion1 conversion2)
2009-06-22 tobias
164
(declare (optimize (speed 3)))
2009-08-27 tobias
165
(and (not (null conversion1))
11:43:13 '
166
(or (null conversion2)
'
167
(<= (the fixnum (conversion-rank conversion1))
'
168
(the fixnum (conversion-rank conversion2))))))
2009-04-17 tobias
169
(:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion))
2009-06-22 tobias
170
(declare (optimize (speed 3)))
2009-07-08 tobias
171
(if (eq (pointer-conversion-from conversion1)
20:41:19 '
172
(pointer-conversion-from conversion2))
2009-04-17 tobias
173
;; A->B < A->C <=> B subclass of C
2009-07-08 tobias
174
(subtypep (pointer-conversion-to conversion1)
20:41:19 '
175
(pointer-conversion-to conversion2))
'
176
(if (eq (pointer-conversion-to conversion1)
'
177
(pointer-conversion-to conversion2))
2009-04-17 tobias
178
;; B->A < C->A <=> B subclass of C
2009-07-08 tobias
179
(subtypep (pointer-conversion-from conversion1)
20:41:19 '
180
(pointer-conversion-from conversion2))
2009-04-17 tobias
181
nil))))
15:26:55 '
182
'
183
(defgeneric conversion= (conversion1 conversion2)
'
184
(:method (conversion1 conversion2)
2009-08-27 tobias
185
(and (conversion<= conversion1 conversion2)
11:43:13 '
186
(conversion<= conversion2 conversion1)))
2009-05-11 tobias
187
(:method ((conversion1 (eql nil)) (conversion2 (eql nil)))
2009-07-22 tobias
188
t))
2009-04-17 tobias
189
15:26:55 '
190
(defun max-conversion (conversion1 conversion2)
2009-05-11 tobias
191
"Returns the greater conversion of CONVERSION1 and CONVERSION2."
2009-04-17 tobias
192
(if (null conversion2)
15:26:55 '
193
conversion1
2009-08-27 tobias
194
(if (conversion<= conversion1 conversion2)
2009-04-17 tobias
195
conversion2
15:26:55 '
196
conversion1)))
2009-05-11 tobias
197
2009-09-01 tobias
198
(defmacro make-match (type &optional (name ''identity) (argument nil)
2009-05-11 tobias
199
&rest args)
2010-02-20 tobias
200
(flet ((conversion-function (name &optional arg)
17:24:36 '
201
(if arg
'
202
`(if (using-typep)
'
203
`(,,name
'
204
,(if (typep ,arg 'class)
'
205
`(find-class ',(class-name ,arg))
'
206
`(find-smoke-method (find-class ,(class-name
'
207
(find-smoke-class
'
208
(get-class ,arg))))
'
209
,(name ,arg))))
'
210
#'(lambda (object)
'
211
(funcall (fdefinition ,name)
'
212
object ,arg)))
'
213
`(if (using-typep)
'
214
,name
'
215
(fdefinition ,name)))))
'
216
`(,(symbolicate 'make- (eval type))
'
217
:function-name ,(conversion-function name argument)
'
218
,@args)))
2009-04-17 tobias
219
2009-05-11 tobias
220
(defun+using-type get-conversion-sequence object (object type &optional user)
2009-07-01 tobias
221
"Retrains a conversion sequence to convert a instance of type CLASS
2009-05-11 tobias
222
to an instance of type TYPE. When USER is true user conversions are considered."
2009-07-08 tobias
223
(if-let (match (call-using-type exact-match object type))
14:56:52 '
224
(if (eql t match)
'
225
(make-match 'exact-match)
'
226
(make-match 'exact-match match))
'
227
(or (call-using-type promotion object type)
'
228
(call-using-type conversion object type)
'
229
(and user
'
230
(call-using-type user-conversion object type)))))
2009-04-17 tobias
231
2009-05-11 tobias
232
(defun+using-types standard-conversion-sequence (method classes &optional user)
11:07:39 '
233
"Returns the conversion sequences to convert the arguments of types CLASSES
'
234
to the types required by METHOD."
2009-08-27 tobias
235
(if (null classes)
11:43:13 '
236
(values (make-match 'exact-match) nil)
'
237
(let ((max-rank)
'
238
(conversions))
'
239
(loop for type in (arguments method)
'
240
for class in classes do
'
241
(let ((rank (call-using-type get-conversion-sequence class type user)))
'
242
(when (null rank)
'
243
(setf max-rank nil)
'
244
(return nil))
'
245
(setf max-rank (max-conversion rank max-rank))
'
246
(push (conversion-function-name rank) conversions)))
'
247
(values max-rank (reverse conversions)))))
2009-04-17 tobias
248
2009-05-11 tobias
249
(defun+using-types conversion-sequence (method classes)
11:07:39 '
250
(call-using-types standard-conversion-sequence method classes t))
2009-04-17 tobias
251
2009-08-27 tobias
252
(defun+using-types find-best-viable-function (name arguments class
11:43:13 '
253
&optional const-p)
2009-05-11 tobias
254
"Returns the method named NAME of class CLASS that can be called
11:07:39 '
255
using arguments of types TYPES with the lowest conversion sequence."
'
256
(call-using-types find-best-viable-function2
'
257
(function-using-types conversion-sequence)
2009-08-27 tobias
258
name arguments class const-p))
2009-04-17 tobias
259
2009-08-27 tobias
260
(defun+using-types find-best-viable-function2 (get-sequence name objects class
11:43:13 '
261
&optional const-p)
2009-05-11 tobias
262
(when (and (using-typep)
11:07:39 '
263
(not (typep class 'smoke-standard-class)))
'
264
(throw 'unspecific-type class))
2009-05-11 tobias
265
(let ((viable-functions (viable-functions name (length objects)
2009-08-27 tobias
266
class const-p))
2009-05-11 tobias
267
(best-rank)
2009-04-17 tobias
268
(best-method)
15:26:55 '
269
(conversions))
2009-08-27 tobias
270
(if (null viable-functions)
11:43:13 '
271
(dolist (class (closer-mop:class-direct-superclasses class)
'
272
(values best-method nil))
'
273
(when (typep class 'smoke-standard-class)
'
274
(multiple-value-bind (method conversions)
'
275
(call-using-types find-best-viable-function2 get-sequence name objects class const-p)
'
276
(when method
'
277
(return (values method conversions))))))
'
278
(loop for method in viable-functions
'
279
finally (return (values best-method conversions)) do
'
280
(block next
'
281
(multiple-value-bind (rank method-conversions)
'
282
(funcall get-sequence method objects)
'
283
(when (and rank (conversion<= rank best-rank))
'
284
(when (conversion= rank best-rank)
'
285
;; FIXME catch all ambigious overloads
'
286
(if const-p
'
287
(error "Ambigious overload ~A." method)
'
288
(when (const-p method)
'
289
;; assume that the previous method is a non
'
290
;; const one and thus more specific.
'
291
(return-from next))))
'
292
(setf best-rank rank)
'
293
(setf best-method method)
'
294
(setf conversions method-conversions)
'
295
(when (and (conversion= rank (make-match 'exact-match))
'
296
(not (xor const-p (const-p method))))
'
297
(return (values method conversions))))))))))
2009-04-17 tobias
298
2009-05-11 tobias
299
(defvar *from-lisp-translations* (make-hash-table :test 'equal))
11:07:39 '
300
'
301
(defmacro define-from-lisp-translation (type-names lisp-type
'
302
&optional
'
303
(conversion-function-name 'identity))
2009-05-11 tobias
304
"Defines a translation from LISP-TYPE to the C++ types TYPE-NAMES using
14:11:35 '
305
the function CONVERSION-FUNCTION-NAME."
2009-05-11 tobias
306
`(progn ,@(loop for type-name in (ensure-list type-names)
2009-05-11 tobias
307
collect `(setf (gethash ,type-name *from-lisp-translations*)
2009-09-02 tobias
308
#'(lambda (type type-p)
11:49:34 '
309
(and (if type-p
2010-02-20 tobias
310
(multiple-value-bind (value valid-p)
17:24:36 '
311
(subtypep type ',lisp-type)
'
312
(unless valid-p
'
313
(throw 'unspecific-type type))
'
314
value)
2009-09-02 tobias
315
(typep type ',lisp-type))
2009-05-11 tobias
316
',conversion-function-name))))))
11:07:39 '
317
'
318
(define-from-lisp-translation ("void*" "const void*" "void**" "const void**")
'
319
foreign-pointer)
'
320
'
321
;; FIXME grovel this?
'
322
(deftype c-integer (ctype)
'
323
(let ((bits (* 8 (foreign-type-size ctype))))
2009-05-11 tobias
324
(if (starts-with-subseq
2009-05-11 tobias
325
(symbol-name :unsigned)
11:07:39 '
326
(symbol-name ctype))
'
327
`(unsigned-byte ,bits)
'
328
`(signed-byte ,bits))))
'
329
'
330
'
331
(defun+using-type exact-match object (object type)
'
332
"Test for an exact match."
2009-04-17 tobias
333
(case (type-id type)
2009-06-22 tobias
334
(0 (when-let (test (gethash (name type) *from-lisp-translations*))
2009-09-02 tobias
335
(funcall test object (using-typep))))
2009-05-11 tobias
336
(1 (object.typep 'boolean))
11:07:39 '
337
(2 (object.typep 'standard-char))
'
338
(3 (object.typep '(c-integer :unsigned-char)))
'
339
(4 (object.typep '(c-integer :short)))
'
340
(5 (object.typep '(c-integer :unsigned-short)))
'
341
(6 (object.typep '(c-integer :int)))
'
342
(7 (object.typep '(c-integer :unsigned-int)))
2010-02-20 tobias
343
(8 (object.typep '(c-integer :long)))
18:01:21 '
344
(9 (object.typep '(c-integer :unsigned-long)))
2009-05-11 tobias
345
(10 (object.typep 'single-float))
11:07:39 '
346
(11 (object.typep 'double-float))
2010-02-20 tobias
347
(12 (when (object.typep 'enum)
17:24:36 '
348
(when (using-typep)
'
349
(throw 'unspecific-type object))
'
350
(smoke-type= type (enum-type object))))
2009-09-09 tobias
351
(13 (and (object.typep 'smoke-standard-object)
19:25:37 '
352
(smoke-type= (get-class type) (object.type-of))))))
2009-05-11 tobias
353
11:07:39 '
354
'
355
(defun make-cleanup-pointer (pointer cleanup-function)
2009-05-26 tobias
356
"Returns a pointer that calls CLEANUP-FUNCTION with pointer as argument
09:54:47 '
357
when it is finalized."
2009-05-11 tobias
358
(let ((address (pointer-address pointer)))
11:07:39 '
359
(tg:finalize pointer #'(lambda ()
'
360
(funcall cleanup-function
'
361
(make-pointer address))))))
'
362
2009-04-17 tobias
363
(defun make-auto-pointer (pointer)
15:26:55 '
364
"Returns a pointer that frees the memory at POINTER when it is finalized."
2009-05-26 tobias
365
(make-cleanup-pointer pointer #'foreign-free))
2009-04-17 tobias
366
2009-05-11 tobias
367
(defun coerce-c-string (string)
11:07:39 '
368
(make-auto-pointer (foreign-string-alloc string)))
'
369
2010-02-20 tobias
370
(defun coerce-enum (enum)
2009-05-11 tobias
371
(cxx-support:value enum))
11:07:39 '
372
2009-07-02 tobias
373
(defun coerce-double-float (number)
21:51:50 '
374
(float number 0d0))
'
375
2010-01-25 tobias
376
(defun coerce-single-float (number)
18:46:41 '
377
(float number 0f0))
'
378
2009-07-02 tobias
379
;; FIXME incomplete
2009-05-11 tobias
380
(defun+using-type promotion object (object type)
2009-04-17 tobias
381
(declare (smoke-type type))
15:26:55 '
382
(case (type-id type)
2009-05-11 tobias
383
(0 (when (and (string= (name type) "const char*")
11:07:39 '
384
(object.typep 'string))
'
385
(make-match 'promotion 'coerce-c-string)))
'
386
(6 (when (object.typep 'enum)
2010-02-20 tobias
387
(make-match 'promotion 'coerce-enum)))
2009-05-11 tobias
388
(7 (when (object.typep 'enum)
2010-02-20 tobias
389
(make-match 'promotion 'coerce-enum)))
2010-01-25 tobias
390
(10 (when (object.typep 'real)
18:46:41 '
391
(make-match 'promotion 'coerce-single-float)))
2009-07-02 tobias
392
(11 (when (object.typep 'real)
2010-02-20 tobias
393
(make-match 'promotion 'coerce-double-float)))))
2009-04-17 tobias
394
2009-05-26 tobias
395
(declaim (inline coerce-to-class))
2009-05-11 tobias
396
(defun coerce-cast (object to-class)
11:07:39 '
397
(cast object to-class))
2009-04-17 tobias
398
2009-05-11 tobias
399
(defun coerce-to-void (object)
11:07:39 '
400
object)
2009-04-17 tobias
401
2009-05-11 tobias
402
(defun+using-type conversion-cast object (object type)
11:07:39 '
403
(when (and (class-p type)
'
404
(object.typep 'smoke-standard-object)
2009-08-27 tobias
405
(derived-p (object.type-of) (get-class type))
11:43:13 '
406
(find-smoke-class (get-class type)))
2009-05-11 tobias
407
(make-match 'pointer-conversion
11:07:39 '
408
'coerce-cast
'
409
(find-smoke-class (get-class type))
'
410
:from (object.type-of)
'
411
:to (find-smoke-class (get-class type)))))
'
412
'
413
(defun+using-type conversion-void object (object type)
'
414
(when (and (string= (name type) "void*")
'
415
(object.typep 'smoke-standard-object))
'
416
(make-match 'pointer-conversion
'
417
'coerce-void
'
418
nil
'
419
:from (object.type-of)
'
420
:to (find-class 't))))
'
421
'
422
(defun+using-type conversion-pointer object (object type)
2009-07-22 tobias
423
;; Not using pointer-p to allow passing a raw pointer for objects on
22:26:05 '
424
;; the stack and references.
2009-05-24 tobias
425
;; (e.g.: for qInstallMsgHandler(QtMsgHandler) )
21:28:44 '
426
;;
2009-07-22 tobias
427
;; FIXME this breaks passing pointers to references.
22:26:05 '
428
;;
'
429
;; e.g.: calling the function foo(QByteArray& foo) with
'
430
;; (foo pointer) assumes pointer to point to a QByteArray, but
'
431
;; actually the conversion sequence QByteArray(pointer) should be
'
432
;; used. When pointer is a null pointer it fails horribly!.
2009-08-02 tobias
433
;;
10:12:41 '
434
;; But it is needed for passing the int pointer in QApplication(int&, char**).
2009-05-24 tobias
435
(when (and (or (= 0 (type-id type)) ; voidp
21:28:44 '
436
(= 13 (type-id type))) ; class
2009-05-11 tobias
437
(object.typep 'foreign-pointer))
11:07:39 '
438
(make-match 'pointer-conversion 'identity nil
2009-08-02 tobias
439
:from (find-class 't)
10:12:41 '
440
:to (find-class 't)))) ;; FIXME get the class when applicable
2009-05-11 tobias
441
11:07:39 '
442
'
443
(defun+using-type conversion object (object type)
'
444
(or (call-using-type conversion-cast object type)
'
445
(call-using-type conversion-void object type)
'
446
(call-using-type conversion-pointer object type)))
'
447
'
448
(defun+using-type user-conversion object (object type)
'
449
(or (call-using-type operator-conversion object type)
'
450
(call-using-type constructor-conversion object type)))
'
451
2009-07-24 tobias
452
(defun conversion-operator-name (to-type)
13:32:23 '
453
(concatenate 'string
'
454
"operator "
'
455
(if (class-p to-type)
'
456
(name (get-class to-type))
2009-08-27 tobias
457
(name to-type))))
2009-07-24 tobias
458
13:32:23 '
459
(defun coerce-to-type (object method)
'
460
(pointer-call method (pointer object)))
'
461
2009-05-11 tobias
462
(defun+using-type operator-conversion object (object type)
11:07:39 '
463
(when (object.typep 'smoke-standard-object)
'
464
(let ((method (find-smoke-method (object.type-of)
2009-07-24 tobias
465
(conversion-operator-name type))))
2009-05-11 tobias
466
(when (valid-p method)
2009-07-24 tobias
467
(if (pointer-p type)
13:32:23 '
468
(make-match 'user-conversion
'
469
'coerce-to-type
'
470
method)
'
471
(make-match 'user-conversion
'
472
(lispify (name method) :cxx)))))))
2009-05-11 tobias
473
2009-05-26 tobias
474
(declaim (inline coerce-to-class))
2009-05-11 tobias
475
(defun coerce-to-class (object to-class)
11:07:39 '
476
(make-instance to-class
'
477
:args (list object)))
'
478
'
479
(defun+using-type constructor-conversion object (object type)
'
480
(when (class-p type)
2010-01-10 tobias
481
(handler-case
17:31:42 '
482
(let ((to-class (find-smoke-class (get-class type) nil)))
'
483
(when (and to-class
'
484
(call-using-types find-best-viable-function2
'
485
(if (using-typep)
'
486
#'standard-conversion-sequence-using-types
'
487
#'standard-conversion-sequence)
'
488
(constructor-name (get-class type))
'
489
(list object) to-class))
'
490
(make-match 'user-conversion
'
491
'coerce-to-class
'
492
to-class)))
'
493
;; When the correspoinding Lisp module is not loaded, we ignore
'
494
;; the overload.
'
495
(lisp-module-not-loaded ()))))
2009-04-17 tobias
496
15:26:55 '
497
(defun call-sequence (method object sequence &rest args)
'
498
(s-call method object
2009-05-11 tobias
499
(mapcar #'(lambda (conversion argument)
11:07:39 '
500
(funcall conversion argument))
'
501
sequence args)))
2009-05-27 tobias
502
17:47:28 '
503
(defun format-no-applicable-cxx-method (stream name class arguments)
'
504
(format stream
'
505
"No applicable method ~S of ~A for ~S.
2009-07-02 tobias
506
Candidates are:~{~T~A~%~}."
2009-05-27 tobias
507
name class arguments
17:47:28 '
508
(mapcar #'signature
'
509
(viable-functions name
'
510
(length arguments)
'
511
(smoke-class-of class)))))
'
512
'
513
(define-condition no-applicable-cxx-method (error)
'
514
((method :initarg :method :reader condition-method)
'
515
(class :initarg :class :reader condition-class)
'
516
(arguments :initarg :arguments :reader condition-arguments))
'
517
(:report (lambda (condition stream)
'
518
(format-no-applicable-cxx-method stream
'
519
(condition-method condition)
'
520
(condition-class condition)
'
521
(condition-arguments condition)))))
2009-09-01 tobias
522
2010-04-03 tobias
523
2009-04-17 tobias
524
(defun call-using-args (object-or-class name arguments)
2009-06-22 tobias
525
"Calls the method NAME of OBJECT-OR-CLASS with ARGUMENTS."
2009-09-09 tobias
526
(declare (optimize (speed 3))
13:22:32 '
527
(type (or smoke-standard-class smoke-standard-object)
'
528
object-or-class))
2009-08-27 tobias
529
(multiple-value-bind (method sequence)
2010-02-20 tobias
530
(#-sbcl find-best-viable-function
17:24:36 '
531
#+sbcl find-best-viable-function-cached
'
532
name
'
533
arguments
'
534
(smoke-class-of object-or-class)
'
535
(when (typep object-or-class
'
536
'smoke-standard-object)
'
537
(const-p object-or-class)))
2009-08-27 tobias
538
(when (null method)
11:43:13 '
539
(error (make-condition 'no-applicable-cxx-method
'
540
:method name
'
541
:class object-or-class
'
542
:arguments arguments)))
2010-02-20 tobias
543
(apply #'call-sequence method
17:24:36 '
544
(if (static-p method)
'
545
(null-pointer)
'
546
(cast object-or-class (get-class method)))
'
547
sequence arguments)))