repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Fix methods and method-maps bounds.
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."
'
136
(make-instance 'smoke-type
2009-05-25 tobias
137
:id (method-slot-value method 'return-type)
2009-06-22 tobias
138
:smoke (smoke-method-smoke method)))
2009-04-05 tobias
139
15:36:29 '
140
(defun method-declaration (method)
'
141
(format nil "~A~:[ void~; ~1:*~A~] ~A::~A"
'
142
(modifiers method)
'
143
(name (return-type method))
'
144
(name (get-class method))
'
145
(signature method)))
'
146
2009-06-22 tobias
147
(defun get-method-flag (method flag)
2009-05-25 tobias
148
(logand (method-slot-value method 'flags)
2009-04-05 tobias
149
(foreign-enum-value 'smoke-method-flags flag)))
15:36:29 '
150
2009-06-22 tobias
151
(define-compiler-macro get-method-flag (&whole form method flag)
12:18:08 '
152
(if (constantp flag)
'
153
`(logand (method-slot-value ,method 'flags)
'
154
;; Resolve flag value at compile time
'
155
,(foreign-enum-value 'smoke-method-flags flag))
'
156
form))
'
157
2009-04-05 tobias
158
(defgeneric constructor-p (object)
15:36:29 '
159
(:documentation "Returns T when OBJECT is a constructor."))
'
160
'
161
(defmethod constructor-p ((method smoke-method))
2009-06-22 tobias
162
(/= 0 (get-method-flag method :constructor)))
2009-04-05 tobias
163
15:36:29 '
164
(defun destructor-p (method)
'
165
"Returns T when METHOD is a destructor; NIL otherwise."
2009-06-22 tobias
166
(/= 0 (get-method-flag method :destructor)))
2009-04-05 tobias
167
15:36:29 '
168
(defun static-p (method)
2009-07-01 tobias
169
"Returns T when METHOD is static and NIL otherwise."
2009-06-22 tobias
170
(/= 0 (get-method-flag method :static)))
2009-04-05 tobias
171
15:36:29 '
172
(defun protected-p (method)
'
173
"Returns T when METHOD is protected; NIL otherwise."
2009-06-22 tobias
174
(/= 0 (get-method-flag method :protected)))
2009-04-05 tobias
175
15:36:29 '
176
(defmethod const-p ((method smoke-method))
'
177
"Returns T when METHOD is a const method and NIL otherwise."
2009-06-22 tobias
178
(/= 0 (get-method-flag method :const)))
12:18:08 '
179
'
180
(defun valid-p (method)
'
181
"Returns T when METHOD is valid and NIL otherwise."
'
182
(/= 0 (smoke-method-id method)))
2009-04-05 tobias
183
15:36:29 '
184
(defun ambigious-p (method)
2009-07-01 tobias
185
"Returns T when METHOD is ambiguous and NIL otherwise."
2009-06-22 tobias
186
(< 0 (smoke-method-id method)))
2009-04-05 tobias
187
15:36:29 '
188
(defun enum-p (method)
'
189
"Returns T when METHOD is enum value and NIL otherwise."
2009-06-22 tobias
190
(/= 0 (get-method-flag method :enum)))
2009-04-05 tobias
191
2009-05-11 tobias
192
(defun internal-p (method)
11:07:39 '
193
"Returns T when METHOD is internal and NIL otherwise."
2009-06-22 tobias
194
(/= 0 (get-method-flag method :internal)))
2009-05-11 tobias
195
2009-04-05 tobias
196
(defmethod get-class ((method smoke-method))
2009-06-22 tobias
197
(make-smoke-class-from-id
12:18:08 '
198
(smoke-method-smoke method)
'
199
(method-slot-value method 'class)))
2009-04-05 tobias
200
15:36:29 '
201
(defclass smoke-argument (smoke-type)
'
202
()
'
203
(:documentation "A argument to a method"))
'
204
'
205
(defmethod id ((argument smoke-argument))
2009-06-22 tobias
206
(declare (optimize (speed 3)))
12:18:08 '
207
(mem-aref (smoke-module-argument-list (smoke argument))
'
208
'smoke-index
2009-07-08 tobias
209
(call-next-method)))
2009-04-05 tobias
210
15:36:29 '
211
(defun last-p (argument)
'
212
"Returns T when ARGUMENT is the last argument and NIL otherwise."
2009-06-22 tobias
213
(= 0 (mem-aref (smoke-module-argument-list (smoke argument))
12:18:08 '
214
'smoke-index
'
215
(1+ (slot-value argument 'id)))))
2009-04-05 tobias
216
15:36:29 '
217
(defun end-p (argument)
'
218
"Returns T when ARGUMENT is the after last element and NIL otherwise."
'
219
(= 0 (id argument)))
'
220
'
221
(defun next (argument)
'
222
"Returns the argument following ARGUMENT."
'
223
(assert (not (end-p argument))
'
224
(argument)
'
225
"Access after end element")
'
226
(make-instance 'smoke-argument
'
227
:id (1+ (slot-value argument 'id))
'
228
:smoke (smoke argument)))
'
229
'
230
(defun get-arguments-length (method)
'
231
"Returns the number of arguments for METHOD."
2009-05-25 tobias
232
(method-slot-value method 'num-args))
2009-04-05 tobias
233
15:36:29 '
234
(defun get-first-argument (method)
'
235
"Returns the first argument of METHOD"
2009-06-22 tobias
236
(declare (optimize (speed 3)))
2009-04-05 tobias
237
(make-instance 'smoke-argument
2009-05-25 tobias
238
:id (method-slot-value method 'arguments)
2009-06-22 tobias
239
:smoke (smoke-method-smoke method)))
2009-04-05 tobias
240
15:36:29 '
241
(defun get-argument (method index)
'
242
"Returns the type of METHODs argument with number INDEX."
'
243
(make-instance 'smoke-argument
2009-05-25 tobias
244
:id (+ (method-slot-value method 'arguments) index)
2009-06-22 tobias
245
:smoke (smoke-method-smoke method)))
2009-04-05 tobias
246
2009-08-02 tobias
247
2009-04-05 tobias
248
(defun build-argument-list (list argument)
15:36:29 '
249
(if (end-p argument)
'
250
list
'
251
(build-argument-list (append list (list argument))
'
252
(next argument))))
'
253
'
254
(defun arguments (method)
'
255
"Returns a list of the arguments of METHOD."
'
256
(build-argument-list nil (get-first-argument method)))
'
257