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