repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Speedup overload resolution and some other stuff for faster C++ method calling.
Annotate for file src/objects/method.lisp
2009-04-05 tobias
1
(in-package #:smoke)
15:36:29 '
2
2009-06-22 tobias
3
(declaim (inline make-smoke-method))
12:18:08 '
4
(defstruct smoke-method
'
5
(id 0 :type smoke-index)
'
6
(smoke (make-smoke-module) :type smoke-module))
'
7
'
8
(declaim (inline smoke-method-pointer))
'
9
(defun smoke-method-pointer (method)
'
10
(declare (optimize (speed 3)))
'
11
(mem-aref (smoke-array-pointer (smoke-module-methods
'
12
(smoke-method-smoke method)))
'
13
'smoke-method
'
14
(smoke-method-id method)))
2009-04-05 tobias
15
15:36:29 '
16
(defmethod print-object ((smoke-method smoke-method) stream)
2009-08-02 tobias
17
(if (or (null-pointer-p (smoke-module-pointer (smoke-method-smoke smoke-method)))
2009-06-22 tobias
18
(null-pointer-p (smoke-method-pointer smoke-method)))
2010-01-17 tobias
19
(call-next-method)
2009-04-05 tobias
20
(print-unreadable-object (smoke-method stream :type t)
15:36:29 '
21
(princ (method-declaration smoke-method) stream))))
'
22
2009-06-22 tobias
23
(defmethod smoke ((method smoke-method))
12:18:08 '
24
(smoke-module-pointer (smoke-method-smoke method)))
'
25
'
26
(defmethod id ((method smoke-method))
'
27
(declare (optimize (speed 3)))
'
28
(smoke-method-id method))
'
29
2009-04-05 tobias
30
(define-condition undefined-method (undefined-function)
15:36:29 '
31
((class-name :initarg :class-name
'
32
:initform nil))
'
33
(:report (lambda (condition stream)
'
34
(format stream "No Smoke method ~S for class ~S."
'
35
(cell-error-name condition)
'
36
(slot-value condition 'class-name))))
'
37
(:documentation "A undefined Smoke method"))
'
38
2009-04-17 tobias
39
(defun find-smoke-method (class name)
15:26:55 '
40
"Returns the method NAME of CLASS."
'
41
(with-foreign-object (m 'smoke-module-index)
2009-06-22 tobias
42
(smoke-find-method m (smoke-module-pointer (smoke class)) (id class) name)
12:18:08 '
43
(let ((smoke (foreign-slot-value m 'smoke-module-index 'smoke)))
'
44
(make-smoke-method
'
45
:smoke (if (null-pointer-p smoke)
'
46
(make-smoke-module)
'
47
(gethash (pointer-address smoke) *smoke-modules*))
'
48
:id (foreign-slot-value m 'smoke-module-index 'index)))))
2009-04-17 tobias
49
2009-04-05 tobias
50
;smoke-find-method
2009-06-22 tobias
51
(defun make-smoke-method-from-name (class name)
2009-04-17 tobias
52
"Returns the method NAME of CLASS.
15:26:55 '
53
Signals a undefined-method condition when no method was found.
2009-07-01 tobias
54
Signals an error when the method is ambiguous."
2009-04-05 tobias
55
(with-foreign-object (m 'smoke-module-index)
15:36:29 '
56
(do () (nil)
2009-06-22 tobias
57
(smoke-find-method m (smoke-module-pointer (smoke class)) (id class) name)
2009-04-05 tobias
58
(restart-case
15:36:29 '
59
(if (null-pointer-p (foreign-slot-value m 'smoke-module-index 'smoke))
'
60
(error (make-condition 'undefined-method :name name :class-name (name class)))
'
61
(return))
'
62
(supply (new-name)
'
63
:report "Supply a new method name"
'
64
:interactive read-new-value
'
65
(setf name new-name))))
'
66
(when (> 0 (foreign-slot-value m 'smoke-module-index 'index))
2009-06-22 tobias
67
(loop as i = (mem-aref (smoke-module-ambiguous-method-list (smoke class))
12:18:08 '
68
'smoke-index
'
69
(- (foreign-slot-value m 'smoke-module-index 'index)))
'
70
while (> i 0)
2009-04-05 tobias
71
do (decf (foreign-slot-value m 'smoke-module-index 'index))
2009-06-22 tobias
72
(let ((m (make-smoke-method :smoke (smoke class) :id i)))
12:18:08 '
73
(format t " ~A ~A~%" (name m) (signature m))))
2009-07-01 tobias
74
(error "The method ~S of ~S is ambiguous" name (name class))) ;;TODO
2009-06-22 tobias
75
(make-smoke-method
12:18:08 '
76
:smoke (gethash (pointer-address
'
77
(foreign-slot-value m 'smoke-module-index 'smoke))
'
78
*smoke-modules*)
'
79
:id (foreign-slot-value m 'smoke-module-index 'index))))
2009-04-05 tobias
80
15:36:29 '
81
(defun map-methods (function smoke)
2009-07-01 tobias
82
"Applies FUNCTION to the methods of SMOKE.
2009-04-05 tobias
83
The method argument to function must not be modified."
2009-04-12 tobias
84
(declare (function function)
20:25:47 '
85
(optimize (speed 3)))
2009-06-22 tobias
86
(let ((method (make-smoke-method :smoke smoke :id 0))
12:18:08 '
87
(length (smoke-array-length (smoke-module-methods smoke))))
2009-07-03 tobias
88
(loop for id from 0 below length do ;; exception: methods is < lenght
2009-06-22 tobias
89
(setf (smoke-method-id method) id)
2009-04-05 tobias
90
(funcall function method))))
15:36:29 '
91
2009-05-26 tobias
92
(declaim (inline method-slot-value))
2009-05-25 tobias
93
(defun method-slot-value (method slot-name)
18:39:33 '
94
(declare (smoke-method method)
'
95
(symbol slot-name)
'
96
(optimize (speed 3)))
2009-06-22 tobias
97
(foreign-slot-value (smoke-method-pointer method)
2009-04-05 tobias
98
'smoke-method slot-name))
15:36:29 '
99
2009-06-22 tobias
100
(define-compiler-macro method-slot-value (&whole form method slot-name)
12:18:08 '
101
"Optimize constant slot-names."
'
102
;; declaring the function inline calls the compiler macro of
'
103
;; foreign-slot-value with 'SLOT-NAME instead of its value an thus
'
104
;; has no effect; thus the compiler macro.
'
105
(if (constantp slot-name)
'
106
`(foreign-slot-value (smoke-method-pointer ,method)
'
107
'smoke-method ,slot-name)
'
108
form))
'
109
'
110
2009-04-05 tobias
111
(defmethod name ((method smoke-method))
2009-06-22 tobias
112
(mem-aref (smoke-array-pointer (smoke-module-method-names
12:18:08 '
113
(smoke-method-smoke method)))
'
114
:string
'
115
(method-slot-value method 'name)))
2009-04-05 tobias
116
15:36:29 '
117
(defun signature (method)
'
118
"Returns the signature of METHOD."
'
119
(format nil "~A(~{~A~^, ~}) ~:[~;const~]"
'
120
(name method)
'
121
(mapcar #'name (arguments method))
'
122
(const-p method)))
'
123
'
124
(defun access (method)
'
125
"Returns the access for METHOD. (public or protected)"
'
126
(if (protected-p method)
'
127
"protected"
'
128
"public"))
'
129
'
130
(defun modifiers (method)
2009-08-02 tobias
131
(format nil "~A~:[~; static~]" (access method)
10:12:41 '
132
(static-p method)))
2009-04-05 tobias
133
15:36:29 '
134
(defun return-type (method)
'
135
"Returns the return type of METHOD."
2009-07-08 tobias
136
(declare (optimize (speed 3)))
2009-04-05 tobias
137
(make-instance 'smoke-type
2009-05-25 tobias
138
:id (method-slot-value method 'return-type)
2009-06-22 tobias
139
:smoke (smoke-method-smoke method)))
2009-04-05 tobias
140
15:36:29 '
141
(defun method-declaration (method)
'
142
(format nil "~A~:[ void~; ~1:*~A~] ~A::~A"
'
143
(modifiers method)
'
144
(name (return-type method))
'
145
(name (get-class method))
'
146
(signature method)))
'
147
2009-06-22 tobias
148
(defun get-method-flag (method flag)
2009-05-25 tobias
149
(logand (method-slot-value method 'flags)
2009-04-05 tobias
150
(foreign-enum-value 'smoke-method-flags flag)))
15:36:29 '
151
2009-06-22 tobias
152
(define-compiler-macro get-method-flag (&whole form method flag)
12:18:08 '
153
(if (constantp flag)
'
154
`(logand (method-slot-value ,method 'flags)
'
155
;; Resolve flag value at compile time
'
156
,(foreign-enum-value 'smoke-method-flags flag))
'
157
form))
'
158
2009-04-05 tobias
159
(defgeneric constructor-p (object)
15:36:29 '
160
(:documentation "Returns T when OBJECT is a constructor."))
'
161
'
162
(defmethod constructor-p ((method smoke-method))
2009-06-22 tobias
163
(/= 0 (get-method-flag method :constructor)))
2009-04-05 tobias
164
15:36:29 '
165
(defun destructor-p (method)
'
166
"Returns T when METHOD is a destructor; NIL otherwise."
2009-06-22 tobias
167
(/= 0 (get-method-flag method :destructor)))
2009-04-05 tobias
168
15:36:29 '
169
(defun static-p (method)
2009-07-01 tobias
170
"Returns T when METHOD is static and NIL otherwise."
2009-06-22 tobias
171
(/= 0 (get-method-flag method :static)))
2009-04-05 tobias
172
15:36:29 '
173
(defun protected-p (method)
'
174
"Returns T when METHOD is protected; NIL otherwise."
2009-06-22 tobias
175
(/= 0 (get-method-flag method :protected)))
2009-04-05 tobias
176
15:36:29 '
177
(defmethod const-p ((method smoke-method))
'
178
"Returns T when METHOD is a const method and NIL otherwise."
2009-06-22 tobias
179
(/= 0 (get-method-flag method :const)))
12:18:08 '
180
'
181
(defun valid-p (method)
'
182
"Returns T when METHOD is valid and NIL otherwise."
'
183
(/= 0 (smoke-method-id method)))
2009-04-05 tobias
184
15:36:29 '
185
(defun ambigious-p (method)
2009-07-01 tobias
186
"Returns T when METHOD is ambiguous and NIL otherwise."
2009-06-22 tobias
187
(< 0 (smoke-method-id method)))
2009-04-05 tobias
188
15:36:29 '
189
(defun enum-p (method)
'
190
"Returns T when METHOD is enum value and NIL otherwise."
2009-06-22 tobias
191
(/= 0 (get-method-flag method :enum)))
2009-04-05 tobias
192
2009-05-11 tobias
193
(defun internal-p (method)
11:07:39 '
194
"Returns T when METHOD is internal and NIL otherwise."
2009-06-22 tobias
195
(/= 0 (get-method-flag method :internal)))
2009-05-11 tobias
196
2009-04-05 tobias
197
(defmethod get-class ((method smoke-method))
2009-06-22 tobias
198
(make-smoke-class-from-id
12:18:08 '
199
(smoke-method-smoke method)
'
200
(method-slot-value method 'class)))
2009-04-05 tobias
201
15:36:29 '
202
(defclass smoke-argument (smoke-type)
'
203
()
'
204
(:documentation "A argument to a method"))
'
205
'
206
(defmethod id ((argument smoke-argument))
2009-06-22 tobias
207
(declare (optimize (speed 3)))
12:18:08 '
208
(mem-aref (smoke-module-argument-list (smoke argument))
'
209
'smoke-index
2009-07-08 tobias
210
(the smoke-index (call-next-method))))
2009-04-05 tobias
211
15:36:29 '
212
(defun last-p (argument)
'
213
"Returns T when ARGUMENT is the last argument and NIL otherwise."
2009-06-22 tobias
214
(= 0 (mem-aref (smoke-module-argument-list (smoke argument))
12:18:08 '
215
'smoke-index
'
216
(1+ (slot-value argument 'id)))))
2009-04-05 tobias
217
15:36:29 '
218
(defun end-p (argument)
'
219
"Returns T when ARGUMENT is the after last element and NIL otherwise."
'
220
(= 0 (id argument)))
'
221
'
222
(defun next (argument)
'
223
"Returns the argument following ARGUMENT."
'
224
(assert (not (end-p argument))
'
225
(argument)
'
226
"Access after end element")
'
227
(make-instance 'smoke-argument
'
228
:id (1+ (slot-value argument 'id))
'
229
:smoke (smoke argument)))
'
230
'
231
(defun get-arguments-length (method)
'
232
"Returns the number of arguments for METHOD."
2009-05-25 tobias
233
(method-slot-value method 'num-args))
2009-04-05 tobias
234
15:36:29 '
235
(defun get-first-argument (method)
'
236
"Returns the first argument of METHOD"
2009-06-22 tobias
237
(declare (optimize (speed 3)))
2009-04-05 tobias
238
(make-instance 'smoke-argument
2009-05-25 tobias
239
:id (method-slot-value method 'arguments)
2009-06-22 tobias
240
:smoke (smoke-method-smoke method)))
2009-04-05 tobias
241
15:36:29 '
242
(defun get-argument (method index)
'
243
"Returns the type of METHODs argument with number INDEX."
'
244
(make-instance 'smoke-argument
2009-05-25 tobias
245
:id (+ (method-slot-value method 'arguments) index)
2009-06-22 tobias
246
:smoke (smoke-method-smoke method)))
2009-04-05 tobias
247
2009-08-02 tobias
248
2009-04-05 tobias
249
(defun build-argument-list (list argument)
15:36:29 '
250
(if (end-p argument)
'
251
list
'
252
(build-argument-list (append list (list argument))
'
253
(next argument))))
'
254
'
255
(defun arguments (method)
'
256
"Returns a list of the arguments of METHOD."
'
257
(build-argument-list nil (get-first-argument method)))
'
258