darcs - smoke

1 (in-package #:smoke)

3 (declaim (inline make-smoke-method))

4 (defstruct smoke-method

5 (id 0 :type smoke-index)

6 (smoke (make-smoke-module) :type smoke-module))

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)))

16 (defmethod print-object ((smoke-method smoke-method) stream)

17 (if (or (null-pointer-p (smoke-module-pointer

18 (smoke-method-smoke smoke-method)))

19 (null-pointer-p (smoke-method-pointer smoke-method)))

20 (print-unreadable-object (smoke-method stream :type t)

21 (princ "no method" stream))

22 (print-unreadable-object (smoke-method stream :type t)

23 (princ (method-declaration smoke-method) stream))))

25 (defmethod smoke ((method smoke-method))

26 (smoke-module-pointer (smoke-method-smoke method)))

28 (defmethod id ((method smoke-method))

29 (declare (optimize (speed 3)))

30 (smoke-method-id method))

32 (define-condition undefined-method (undefined-function)

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"))

41 (defun find-smoke-method (class name)

42 "Returns the method NAME of CLASS."

43 (with-foreign-object (m 'smoke-module-index)

44 (smoke-find-method m (smoke-module-pointer (smoke class)) (id class) name)

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)))))

52 (declaim (inline smoke-method-name))

53 (defun smoke-method-name (method)

54 (mem-aref (smoke-array-pointer (smoke-module-method-names

55 (smoke-method-smoke method)))

56 :pointer

57 (the (smoke-index 0) (method-slot-value method 'name))))

59 ;smoke-find-method

60 (defun make-smoke-method-from-name (class name)

61 "Returns the method NAME of CLASS.

62 Signals a undefined-method condition when no method was found.

63 Signals an error when the method is ambiguous."

64 (with-foreign-object (m 'smoke-module-index)

65 (do () (nil)

66 (smoke-find-method m (smoke-module-pointer (smoke class)) (id class) name)

67 (restart-case

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))

76 (loop as i = (mem-aref (smoke-module-ambiguous-method-list (smoke class))

77 'smoke-index

78 (- (foreign-slot-value m 'smoke-module-index 'index)))

79 while (> i 0)

80 do (decf (foreign-slot-value m 'smoke-module-index 'index))

81 (let ((m (make-smoke-method :smoke (smoke class) :id i)))

82 (format t " ~A ~A~%" (name m) (signature m))))

83 (error "The method ~S of ~S is ambiguous" name (name class))) ;;TODO

84 (make-smoke-method

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))))

90 (defun map-methods (function smoke)

91 "Applies FUNCTION to the methods of SMOKE.

92 The method argument to function must not be modified."

93 (declare (function function)

94 (optimize (speed 3)))

95 (let ((method (make-smoke-method :smoke smoke :id 0))

96 (length (smoke-array-length (smoke-module-methods smoke))))

97 (loop for id from 0 below length do ;; exception: methods is < lenght

98 (setf (smoke-method-id method) id)

99 (funcall function method))))

100

101 (declaim (inline method-slot-value))

102 (defun method-slot-value (method slot-name)

103 (declare (smoke-method method)

104 (symbol slot-name)

105 (optimize (speed 3)))

106 (foreign-slot-value (smoke-method-pointer method)

107 'smoke-method slot-name))

108

109 (define-compiler-macro method-slot-value (&whole form method slot-name)

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

120 (defmethod name ((method smoke-method))

121 (mem-aref (smoke-array-pointer (smoke-module-method-names

122 (smoke-method-smoke method)))

123 :string

124 (method-slot-value method 'name)))

125

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)

140 (format nil "~:[~;virtual ~]~A~:[~; static~]"

141 (virtual-p method) (access method) (static-p method)))

142

143 (defun return-type (method)

144 "Returns the return type of METHOD."

145 (declare (optimize (speed 3)))

146 (make-instance 'smoke-type

147 :id (method-slot-value method 'return-type)

148 :smoke (smoke-method-smoke method)))

149

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

157 (defun get-method-flag (method flag)

158 (logand (method-slot-value method 'flags)

159 (foreign-enum-value 'smoke-method-flags flag)))

160

161 (define-compiler-macro get-method-flag (&whole form method flag)

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

168 (defgeneric constructor-p (object)

169 (:documentation "Returns T when OBJECT is a constructor."))

170

171 (defmethod constructor-p ((method smoke-method))

172 (/= 0 (get-method-flag method :constructor)))

173

174 (defun destructor-p (method)

175 "Returns T when METHOD is a destructor; NIL otherwise."

176 (/= 0 (get-method-flag method :destructor)))

177

178 (defun static-p (method)

179 "Returns T when METHOD is static and NIL otherwise."

180 (/= 0 (get-method-flag method :static)))

181

182 (defun protected-p (method)

183 "Returns T when METHOD is protected; NIL otherwise."

184 (/= 0 (get-method-flag method :protected)))

185

186 (defun attribute-p (method)

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

194 (defmethod const-p ((method smoke-method))

195 "Returns T when METHOD is a const method and NIL otherwise."

196 (/= 0 (get-method-flag method :const)))

197

198 (defun valid-p (method)

199 "Returns T when METHOD is valid and NIL otherwise."

200 (/= 0 (smoke-method-id method)))

201

202 (defun ambigious-p (method)

203 "Returns T when METHOD is ambiguous and NIL otherwise."

204 (< 0 (smoke-method-id method)))

205

206 (defun enum-p (method)

207 "Returns T when METHOD is enum value and NIL otherwise."

208 (/= 0 (get-method-flag method :enum)))

209

210 (defun internal-p (method)

211 "Returns T when METHOD is internal and NIL otherwise."

212 (/= 0 (get-method-flag method :internal)))

213

214 (defun virtual-p (method)

215 "Returns T when METHOD is internal and NIL otherwise."

216 (/= 0 (get-method-flag method :virtual)))

217

218 (defmethod get-class ((method smoke-method))

219 (make-smoke-class-from-id

220 (smoke-method-smoke method)

221 (method-slot-value method 'class)))

222

223 (defclass smoke-argument (smoke-type)

224 ()

225 (:documentation "A argument to a method"))

226

227 (defmethod id ((argument smoke-argument))

228 (declare (optimize (speed 3)))

229 (mem-aref (smoke-module-argument-list (smoke argument))

230 'smoke-index

231 (the smoke-index (call-next-method))))

232

233 (defun last-p (argument)

234 "Returns T when ARGUMENT is the last argument and NIL otherwise."

235 (= 0 (mem-aref (smoke-module-argument-list (smoke argument))

236 'smoke-index

237 (1+ (slot-value argument 'id)))))

238

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."

254 (method-slot-value method 'num-args))

255

256 (defun get-first-argument (method)

257 "Returns the first argument of METHOD"

258 (declare (optimize (speed 3)))

259 (make-instance 'smoke-argument

260 :id (method-slot-value method 'arguments)

261 :smoke (smoke-method-smoke method)))

262

263 (defun get-argument (method index)

264 "Returns the type of METHODs argument with number INDEX."

265 (make-instance 'smoke-argument

266 :id (+ (method-slot-value method 'arguments) index)

267 :smoke (smoke-method-smoke method)))

268

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)))