repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Cleanup C++ to Lisp translation
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
(call-next-method)
2009-04-05 tobias
21
(print-unreadable-object (smoke-method stream :type t)
15:36:29 '
22
(princ (method-declaration smoke-method) stream))))
'
23
2009-06-22 tobias
24
(defmethod smoke ((method smoke-method))
12:18:08 '
25
(smoke-module-pointer (smoke-method-smoke method)))
'
26
'
27
(defmethod id ((method smoke-method))
'
28
(declare (optimize (speed 3)))
'
29
(smoke-method-id method))
'
30
2009-04-05 tobias
31
(define-condition undefined-method (undefined-function)
15:36:29 '
32
((class-name :initarg :class-name
'
33
:initform nil))
'
34
(:report (lambda (condition stream)
'
35
(format stream "No Smoke method ~S for class ~S."
'
36
(cell-error-name condition)
'
37
(slot-value condition 'class-name))))
'
38
(:documentation "A undefined Smoke method"))
'
39
2009-04-17 tobias
40
(defun find-smoke-method (class name)
15:26:55 '
41
"Returns the method NAME of CLASS."
'
42
(with-foreign-object (m 'smoke-module-index)
2009-06-22 tobias
43
(smoke-find-method m (smoke-module-pointer (smoke class)) (id class) name)
12:18:08 '
44
(let ((smoke (foreign-slot-value m 'smoke-module-index 'smoke)))
'
45
(make-smoke-method
'
46
:smoke (if (null-pointer-p smoke)
'
47
(make-smoke-module)
'
48
(gethash (pointer-address smoke) *smoke-modules*))
'
49
:id (foreign-slot-value m 'smoke-module-index 'index)))))
2009-04-17 tobias
50
2009-07-22 tobias
51
(declaim (inline smoke-method-name))
22:26:05 '
52
(defun smoke-method-name (method)
'
53
(mem-aref (smoke-array-pointer (smoke-module-method-names
'
54
(smoke-method-smoke method)))
'
55
:pointer
2009-08-02 tobias
56
(the (smoke-index 0) (method-slot-value method 'name))))
2009-07-22 tobias
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) (static-p method)))
2009-04-05 tobias
140
15:36:29 '
141
(defun return-type (method)
'
142
"Returns the return type of METHOD."
2009-07-08 tobias
143
(declare (optimize (speed 3)))
2009-04-05 tobias
144
(make-instance 'smoke-type
2009-05-25 tobias
145
:id (method-slot-value method 'return-type)
2009-06-22 tobias
146
:smoke (smoke-method-smoke method)))
2009-04-05 tobias
147
15:36:29 '
148
(defun method-declaration (method)
'
149
(format nil "~A~:[ void~; ~1:*~A~] ~A::~A"
'
150
(modifiers method)
'
151
(name (return-type method))
'
152
(name (get-class method))
'
153
(signature method)))
'
154
2009-06-22 tobias
155
(defun get-method-flag (method flag)
2009-05-25 tobias
156
(logand (method-slot-value method 'flags)
2009-04-05 tobias
157
(foreign-enum-value 'smoke-method-flags flag)))
15:36:29 '
158
2009-06-22 tobias
159
(define-compiler-macro get-method-flag (&whole form method flag)
12:18:08 '
160
(if (constantp flag)
'
161
`(logand (method-slot-value ,method 'flags)
'
162
;; Resolve flag value at compile time
'
163
,(foreign-enum-value 'smoke-method-flags flag))
'
164
form))
'
165
2009-04-05 tobias
166
(defgeneric constructor-p (object)
15:36:29 '
167
(:documentation "Returns T when OBJECT is a constructor."))
'
168
'
169
(defmethod constructor-p ((method smoke-method))
2009-06-22 tobias
170
(/= 0 (get-method-flag method :constructor)))
2009-04-05 tobias
171
15:36:29 '
172
(defun destructor-p (method)
'
173
"Returns T when METHOD is a destructor; NIL otherwise."
2009-06-22 tobias
174
(/= 0 (get-method-flag method :destructor)))
2009-04-05 tobias
175
15:36:29 '
176
(defun static-p (method)
2009-07-01 tobias
177
"Returns T when METHOD is static and NIL otherwise."
2009-06-22 tobias
178
(/= 0 (get-method-flag method :static)))
2009-04-05 tobias
179
15:36:29 '
180
(defun protected-p (method)
'
181
"Returns T when METHOD is protected; NIL otherwise."
2009-06-22 tobias
182
(/= 0 (get-method-flag method :protected)))
2009-04-05 tobias
183
15:36:29 '
184
(defmethod const-p ((method smoke-method))
'
185
"Returns T when METHOD is a const method and NIL otherwise."
2009-06-22 tobias
186
(/= 0 (get-method-flag method :const)))
12:18:08 '
187
'
188
(defun valid-p (method)
'
189
"Returns T when METHOD is valid and NIL otherwise."
'
190
(/= 0 (smoke-method-id method)))
2009-04-05 tobias
191
15:36:29 '
192
(defun ambigious-p (method)
2009-07-01 tobias
193
"Returns T when METHOD is ambiguous and NIL otherwise."
2009-06-22 tobias
194
(< 0 (smoke-method-id method)))
2009-04-05 tobias
195
15:36:29 '
196
(defun enum-p (method)
'
197
"Returns T when METHOD is enum value and NIL otherwise."
2009-06-22 tobias
198
(/= 0 (get-method-flag method :enum)))
2009-04-05 tobias
199
2009-05-11 tobias
200
(defun internal-p (method)
11:07:39 '
201
"Returns T when METHOD is internal and NIL otherwise."
2009-06-22 tobias
202
(/= 0 (get-method-flag method :internal)))
2009-05-11 tobias
203
2009-04-05 tobias
204
(defmethod get-class ((method smoke-method))
2009-06-22 tobias
205
(make-smoke-class-from-id
12:18:08 '
206
(smoke-method-smoke method)
'
207
(method-slot-value method 'class)))
2009-04-05 tobias
208
15:36:29 '
209
(defclass smoke-argument (smoke-type)
'
210
()
'
211
(:documentation "A argument to a method"))
'
212
'
213
(defmethod id ((argument smoke-argument))
2009-06-22 tobias
214
(declare (optimize (speed 3)))
12:18:08 '
215
(mem-aref (smoke-module-argument-list (smoke argument))
'
216
'smoke-index
2009-07-08 tobias
217
(the smoke-index (call-next-method))))
2009-04-05 tobias
218
15:36:29 '
219
(defun last-p (argument)
'
220
"Returns T when ARGUMENT is the last argument and NIL otherwise."
2009-06-22 tobias
221
(= 0 (mem-aref (smoke-module-argument-list (smoke argument))
12:18:08 '
222
'smoke-index
'
223
(1+ (slot-value argument 'id)))))
2009-04-05 tobias
224
15:36:29 '
225
(defun end-p (argument)
'
226
"Returns T when ARGUMENT is the after last element and NIL otherwise."
'
227
(= 0 (id argument)))
'
228
'
229
(defun next (argument)
'
230
"Returns the argument following ARGUMENT."
'
231
(assert (not (end-p argument))
'
232
(argument)
'
233
"Access after end element")
'
234
(make-instance 'smoke-argument
'
235
:id (1+ (slot-value argument 'id))
'
236
:smoke (smoke argument)))
'
237
'
238
(defun get-arguments-length (method)
'
239
"Returns the number of arguments for METHOD."
2009-05-25 tobias
240
(method-slot-value method 'num-args))
2009-04-05 tobias
241
15:36:29 '
242
(defun get-first-argument (method)
'
243
"Returns the first argument of METHOD"
2009-06-22 tobias
244
(declare (optimize (speed 3)))
2009-04-05 tobias
245
(make-instance 'smoke-argument
2009-05-25 tobias
246
:id (method-slot-value method 'arguments)
2009-06-22 tobias
247
:smoke (smoke-method-smoke method)))
2009-04-05 tobias
248
15:36:29 '
249
(defun get-argument (method index)
'
250
"Returns the type of METHODs argument with number INDEX."
'
251
(make-instance 'smoke-argument
2009-05-25 tobias
252
:id (+ (method-slot-value method 'arguments) index)
2009-06-22 tobias
253
:smoke (smoke-method-smoke method)))
2009-04-05 tobias
254
15:36:29 '
255
(defun build-argument-list (list argument)
'
256
(if (end-p argument)
'
257
list
'
258
(build-argument-list (append list (list argument))
'
259
(next argument))))
'
260
'
261
(defun arguments (method)
'
262
"Returns a list of the arguments of METHOD."
'
263
(build-argument-list nil (get-first-argument method)))
'
264