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