darcs - smoke

1 (in-package #:smoke)

3 (declaim (inline lispify))

4 (defun lispify (name &optional (package nil))

5 "Returns the interned symbol for name in Lisp style."

6 (declare (string name)

7 (optimize (speed 3)))

8 (if (null package)

9 (values (intern (cxx-to-lisp name)))

10 (values (intern (cxx-to-lisp name) package))))

12 (defmacro define-string-transform (name documentation &body states)

13 "Defines a function to transform a string."

14 (let ((output (gensym))

15 (index (gensym))

16 (length (gensym)))

17 `(defun ,name (input)

18 ,documentation

19 (declare (simple-string input)

20 (optimize (speed 3)))

21 ;; At least on sbcl 1.0.25.debian CONCATENATE is faster than

22 ;; VECTOR-PUSH-EXTEND.

23 (let ((,output "")

24 (,index 0)

25 (,length (length input))

26 (char #\Null))

27 (declare (base-char char))

28 (macrolet ((next-char ()

29 `(if (>= ,',index ,',length)

30 (return-from transform ,',output)

31 (progn

32 (setf char (aref input ,',index))

33 (incf ,',index))))

34 (go-next (tag)

35 `(progn (next-char)

36 (go ,tag)))

37 (append-char (char)

38 `(setf ,',output (concatenate 'string

39 ,',output

40 (string ,char)))))

41 (block transform

42 (tagbody

43 (next-char) ;; Get first char

44 ,@(reduce #'append

45 (mapcar #'(lambda (state)

46 (if (stringp (second state))

47 `(,(first state) . ,(cddr state))

48 state))

49 states)))))))))

52 (define-string-transform lisp-to-cxx

53 "Converts LISP-STYLE to camelCase.

54 Note that (LISP-TO-CXX (CXX-TO-LIST SOME-STRING)) will not necessarily return

55 a string equal to SOME-STRING."

56 (default

57 "Down case, convert _ and dispatch."

58 (case char

59 (#\- (go-next camel-upcase))

60 (#\. (go-next namespace))

61 (t (append-char (char-downcase char))

62 (go-next default))))

63 (camel-upcase

64 "Convert camelCase to lisp-style."

65 (append-char char)

66 (go-next default))

67 (namespace

68 "Convert . to ::"

69 (append-char #\:)

70 (append-char #\:)

71 (go default)))

73 (define-string-transform cxx-to-lisp

74 "Returns camelCase STRING in lisp-style."

75 (begin

76 "Strip leading Q or K."

77 (case char

78 (#\K (go-next default))

79 (#\Q (go-next default))

80 (t (go default))))

81 (default

82 "Up case, convert _ and dispatch."

83 (case char

84 (#\: (go-next namespace))

85 (#\_ (append-char #\-)

86 (go-next default))

87 (#\ (append-char #\-) ;; space (cast operators)

88 (go-next default))

89 (t (append-char (char-upcase char))

90 (if (lower-case-p char)

91 (go-next camel-case)

92 (go-next default)))))

93 (namespace

94 "C++ namespace separator"

95 (assert (eql #\: char))

96 (append-char #\.)

97 (go-next default))

98 (camel-case

99 "Convert camelCase to lisp-style."

100 (if (upper-case-p char)

101 (progn

102 (append-char #\-)

103 (append-char char)

104 (go-next default))

105 (go default))))

106

107

108 (defmethod print-object ((object smoke-standard-object) stream)

109 (if (slot-boundp object 'pointer)

110 (print-unreadable-object (object stream :type t)

111 (when (const-p object)

112 (princ "CONST " stream))

113 (princ (pointer object) stream))

114 (call-next-method)))

115

116 (defclass smoke-standard-class (standard-class smoke-class)

117 ()

118 (:documentation "A Smoke C++ class"))

119

120 (defclass cxx:class (smoke-standard-class)

121 ()

122 (:documentation "Metaclass to extend Smoke Objects."))

123

124 (defclass smoke-multi-superclass-mixin ()

125 ((extra-objects :reader extra-objects

126 :initarg :extra-objects)))

127

128 (defmethod closer-mop:validate-superclass ((class smoke-standard-class)

129 (superclass standard-class))

130 t)

131

132 (defmethod closer-mop:validate-superclass ((class cxx:class)

133 (superclass smoke-standard-class))

134 t)

135

136 ;; Sets NIL superclass to SMOKE-STANDARD-OBJECT instead of the default

137 ;; STANDARD-OBJECT.

138 (defun init-smoke-standard-class (class next-method

139 &rest args &key direct-superclasses

140 &allow-other-keys)

141 (apply next-method class

142 :direct-superclasses (or direct-superclasses

143 (list (find-class 'smoke-standard-object)))

144 args))

145

146 (defmethod initialize-instance :around ((class smoke-standard-class) &rest args)

147 (apply #'init-smoke-standard-class class #'call-next-method args))

148

149 (defmethod reinitialize-instance :around ((class smoke-standard-class) &rest args)

150 (apply #'init-smoke-standard-class class #'call-next-method args))

151

152

153 (defun init-cxx-class (class next-method &rest args &key direct-superclasses

154 direct-default-initargs &allow-other-keys)

155 (assert (not (null direct-superclasses))

156 (direct-superclasses)

157 "No superclass supplied for class ~A" class)

158 (let ((superclass (first direct-superclasses))

159 (extra-superclasses (remove-if-not #'(lambda (class)

160 (typep class 'smoke-standard-class))

161 (rest direct-superclasses))))

162 (assert (typep superclass 'smoke-standard-class)

163 ((first direct-superclasses))

164 "The first superclass ~A must be an subclass of an Smoke class."

165 class)

166 (assert (virtual-destructor-p superclass)

167 ()

168 "The superclass ~A of ~A has a non virtual destructor."

169 superclass class)

170 (when extra-superclasses

171 (dolist (superclass extra-superclasses)

172 (unless (virtual-destructor-p superclass)

173 (cerror "Continue anyway"

174 "The superclass ~A of ~A has a non virtual destructor."

175 superclass class)))

176 (setf direct-superclasses

177 (append direct-superclasses

178 (list (find-class 'smoke-multi-superclass-mixin))))

179 (push `(:extra-objects ,extra-superclasses ,#'(lambda ()

180 extra-superclasses))

181 direct-default-initargs))

182 (apply

183 next-method class

184 :id (id superclass)

185 :smoke (smoke superclass)

186 :direct-superclasses direct-superclasses

187 :direct-default-initargs direct-default-initargs

188 args)))

189

190 (defmethod reinitialize-instance :around ((class cxx:class) &rest args)

191 (apply #'init-cxx-class class #'call-next-method args))

192

193 (defmethod initialize-instance :around ((class cxx:class) &rest args)

194 (apply #'init-cxx-class class #'call-next-method args))

195

196 (defun smoke-class-symbols (classes)

197 (let ((class-symbols))

198 (dolist (class classes class-symbols)

199 (if (external-p class)

200 (let ((real-class (find-smoke-class class nil)))

201 (when real-class

202 (push (class-name real-class) class-symbols)))

203 (push (lispify (name class)) class-symbols)))))

204

205 (defun make-smoke-classes (package smoke)

206 "Constructs a lisp class in PACKAGE for each one in the Smoke module SMOKE."

207 (declare (optimize (speed 3)))

208 (let ((impl-package *package*)

209 (*package* (find-package package)))

210 (add-id-class-map smoke)

211 (map-classes

212 #'(lambda (class)

213 (unless (external-p class)

214 (with-simple-restart (skip "Skip generating class ~A" (name class))

215 (let ((class-name

216 ;; There is a QGlobalSpace class per Smoke module.

217 ;; Put it in *package* and not PACKAGE to avoid

218 ;; clashes between multiple modules.

219 (if (string= "QGlobalSpace" (name class))

220 (lispify "QGlobalSpace" impl-package)

221 (lispify (name class)))))

222 (add-id class

223 (closer-mop:ensure-class class-name

224 :direct-superclasses

225 (smoke-class-symbols

226 (smoke-class-direct-superclasses class))

227 :id (id class)

228 :smoke (smoke class)

229 :metaclass 'smoke-standard-class))

230 (when (eql (symbol-package class-name) *package*)

231 (export class-name))))))

232 smoke)))

233

234 (defclass smoke-gf (cxx-generic-function)

235 ((cxx-name :reader name :initarg :cxx-name

236 :type string

237 :documentation "The C++ name of the method."))

238 (:metaclass closer-mop:funcallable-standard-class)

239 (:documentation "Smoke generic function."))

240

241 (declaim (inline smoke-class-of))

242 (defun smoke-class-of (object)

243 "Returns the class of OBJECT or OBJECT iff it already is a class."

244 (declare (optimize (speed 3)))

245 (if (typep object 'smoke-class)

246 object

247 (class-of object)))

248

249 ;;; To speed up the startup

250 ;;; ENSURE-METHOD is only called as needed.

251 (defmethod no-applicable-method ((gf smoke-gf) &rest args)

252 "Calls the smoke method."

253 (declare (dynamic-extent args)

254 (optimize (speed 3)))

255 (call-using-args (first args) (name gf) (rest args)))

256

257 (defmethod add-method :after ((gf cxx-method-generic-function) method)

258 "Adds a method which calls the smoke method, to make call-next-method work."

259 (when (null (rest (closer-mop:generic-function-methods gf)))

260 (let ((lambda-list (closer-mop:method-lambda-list method)))

261 (closer-mop:ensure-method

262 gf

263 `(lambda ,lambda-list

264 (declare (optimize (speed 3)))

265 (call-using-args ,(first lambda-list)

266 (name ,(cxx-generic-function gf))

267 (list ,@(rest lambda-list))))))))

268

269 (defcallback destructed :void

270 ((object-pointer :pointer))

271 (declare (optimize (speed 3)))

272 (let ((object (get-object object-pointer)))

273 ;; The destructed callback can be the result of deleting the object

274 ;; in a finalizer. In that case the object is already removed from

275 ;; *object-map* when the callback is invoked. Thus OBJECT can be NIL.

276 (when object

277 (when (typep object 'smoke-multi-superclass-mixin)

278 (dolist (extra-object (extra-objects object))

279 (unless (null-pointer-p (pointer extra-object))

280 (remove-object (pointer extra-object))

281 (delete-object extra-object))))

282 (remove-finalizer object)

283 (remove-object object-pointer)

284 (setf (slot-value object 'pointer) (null-pointer)))))

285

286 (declaim (inline argument-to-lisp))

287 (defun argument-to-lisp (stack-item type)

288 ;; FIXME do not take ownership of stack allocated objects.

289 ;; It looks like there is no stack allocation in Qt virtual method signatures.

290 (type-to-lisp stack-item type))

291

292 (defun stack-to-args (stack arg &optional (args nil))

293 "Returns the arguments in STACK, where ARG is the type

294 of the first argument, as an list of Lisp objects."

295 (if (end-p arg)

296 (reverse args)

297 (stack-to-args (inc-pointer stack

298 (foreign-type-size 'smoke-stack-item))

299 (next arg)

300 (cons (argument-to-lisp (mem-ref stack 'smoke-stack-item)

301 arg)

302 args))))

303

304 (defun convert-argument (argument type &optional disown)

305 "Returns ARGUMENT converted to TYPE and removes the ownership when

306 it is passed on the stack."

307 (flet ((disown (object)

308 (remove-finalizer object)

309 (when (typep object 'smoke-standard-object)

310 (remove-object (pointer object)))))

311 (let ((rank (get-conversion-sequence argument type nil)))

312 (if (null rank)

313 (let ((rank (get-conversion-sequence argument type t)))

314 (if (null rank)

315 (error "Can not convert the argument ~S to ~A."

316 argument (name type))

317 (let ((ret (funcall (conversion-function-name rank)

318 argument)))

319 (when (and disown (stack-p type))

320 (disown ret))

321 ret)))

322 (prog1 (funcall (conversion-function-name rank) argument)

323 (when (and disown (stack-p type))

324 (disown argument)))))))

325

326 (defun put-returnvalue (stack value type object)

327 (unless (void-p type)

328 (let ((stack (make-call-stack stack)))

329 (setf (call-stack-top stack) (call-stack-pointer stack))

330 (let ((converted-value (convert-argument value type t)))

331 (push-smoke-stack stack converted-value (type-id type))))))

332

333 (defun get-gf-for-method (smoke-method)

334 (declare (smoke-method smoke-method)

335 (optimize (speed 3)))

336 (symbol-function (lispify (name smoke-method) "CXX")))

337

338 ;; Receive virtual function calls.

339 (defcallback dispatch-method :boolean

340 ((method smoke-index)

341 (object-ptr :pointer)

342 (stack smoke-stack)

343 (abstract :boolean))

344 (declare (optimize (speed 3)))

345 (let ((object (get-object object-ptr)))

346 ;; The Lisp OBJECT can be gc'ed but we might still receive a

347 ;; QObject destructed event when the C++ instance is deleted in

348 ;; the finalizer. Thus OBJECT might be NIL.

349 (unless (null object)

350 (let* ((method (make-smoke-method

351 :smoke (smoke (class-of object))

352 :id method)))

353 (loop

354 (restart-case

355 (return-from dispatch-method

356 (let ((gf (get-gf-for-method method)))

357 (declare (function gf))

358 (if (null (gf-methods gf))

359 (progn

360 (when abstract

361 (error "Abstract method ~A of ~A called."

362 (method-declaration method) object))

363 nil)

364 (if object

365 (progn

366 (put-returnvalue

367 stack

368 (apply gf object

369 (stack-to-args

370 (inc-pointer stack (foreign-type-size

371 'smoke-stack-item))

372 (get-first-argument method)))

373 (return-type method) object)

374 t)

375 nil))))

376 ;; Restarts to prevent stack unwinding across the C++ stack.

377 (call-default ()

378 :report (lambda (stream)

379 (declare (stream stream))

380 (format stream

381 "Call default implementation ~A instead."

382 method))

383 :test (lambda (condition)

384 (declare (ignore condition))

385 (not abstract))

386 (return-from dispatch-method nil))

387 (use-returnvalue (return-value)

388 :report (lambda (stream)

389 (declare (stream stream))

390 (format stream "Supply a return value for ~A."

391 (method-declaration method)))

392 :test (lambda (condition)

393 (declare (ignore condition))

394 (not (void-p (return-type method))))

395 :interactive (lambda ()

396 (format *query-io* "~&Enter a new return value: ")

397 (multiple-value-list (eval (read *query-io*))))

398 (put-returnvalue stack return-value

399 (return-type method)

400 (get-object object-ptr))

401 (return-from dispatch-method t))

402 (return ()

403 :report (lambda (stream)

404 (declare (stream stream))

405 (format stream "Return void for ~A."

406 (method-declaration method)))

407 :test (lambda (condition)

408 (declare (ignore condition))

409 (void-p (return-type method)))

410 (return-from dispatch-method (values)))

411 (retry ()

412 :report (lambda (stream)

413 (declare (stream stream))

414 (format stream "Try again calling ~A."

415 (method-declaration method))))))

416 nil))))

417

418 ;;FIXME use CHANGE-CLASS instead?

419 (defgeneric cast (object class)

420 (declare (optimize (speed 3)))

421 (:documentation "Returns a pointer of type CLASS to the C++ object of OBJECT.")

422 (:method (object class)

423 (declare (optimize (speed 3)))

424 (assert (derived-p (class-of object) class)

425 ()

426 "Can not cast object ~A of class ~A to class ~A."

427 object (name (class-of object)) (name class))

428 (smoke-cast (smoke-module-pointer (smoke (class-of object))) (pointer object)

429 (id (class-of object))

430 (smoke-class-id (smoke-module-pointer (smoke (class-of object)))

431 (name-pointer class))))

432 (:method ((object smoke-multi-superclass-mixin) class)

433 (if (derived-p (class-of object) class)

434 (call-next-method)

435 (let ((extra-object (find-if #'(lambda (o)

436 (derived-p (class-of o) class))

437 (extra-objects object))))

438 (assert extra-object

439 ()

440 "Can not cast object ~A to class ~A."

441 object (name class))

442 (cast extra-object class)))))

443

444 (defun upcast (object class)

445 (assert (derived-p class (class-of object))

446 ()

447 "Can not upcast object ~A of class ~A to class ~A."

448 object (name (class-of object)) (name class))

449 (smoke-cast (smoke-module-pointer (smoke class)) (pointer object)

450 (id (class-of object)) (id (real-class class))))

451

452

453 ;; The constructor name is the name of the class minus any namespace parts.

454 (defun constructor-name (class)

455 (declare (optimize (speed 3)))

456 (let* ((name (the simple-string (name class)))

457 (name-start (search "::" name :from-end t)))

458 (if name-start

459 (subseq name (+ name-start 2))

460 name)))

461

462 (defun call-constructor (class arguments)

463 (multiple-value-bind (method sequence)

464 (#-sbcl find-best-viable-function

465 #+sbcl find-best-viable-function-cached

466 (constructor-name class)

467 arguments

468 class nil)

469 (when (null method)

470 (error "No constructor for class ~A with

471 the arguments ~S." class arguments))

472 (pointer-call method (null-pointer)

473 (mapcar #'(lambda (conversion argument)

474 (funcall conversion argument))

475 sequence arguments))))

476

477 (defmethod initialize-instance :after ((object smoke-standard-object)

478 &key args

479 (arg0 nil arg0p)

480 (arg1 nil arg1p)

481 (arg2 nil arg2p)

482 (arg3 nil arg3p)

483 &allow-other-keys)

484 "Initializes a Smoke object. Calls its constructor with the arguments supplied

485 by the key :ARGS and sets the smoke binding."

486 (declare (optimize (speed 3)))

487 (assert (not (and (slot-boundp object 'pointer)

488 (not (null args))))

489 ((slot-value object 'pointer) args)

490 "Pointer ~A bound and constructor argument :ARGS ~S supplied."

491 (slot-value object 'pointer) args)

492 (unless (slot-boundp object 'pointer)

493 (if arg0p

494 (setf (slot-value object 'pointer)

495 (call-constructor (class-of object)

496 (cond

497 (arg3p (list arg0 arg1 arg2 arg3))

498 (arg2p (list arg0 arg1 arg2))

499 (arg1p (list arg0 arg1))

500 (t (list arg0)))))

501 (setf (slot-value object 'pointer)

502 (call-constructor (class-of object) args)))

503 (set-binding object)

504 (take-ownership object)

505 (add-object object)))

506

507 (defun construct-extra-objects (object extra-objects)

508 (loop for class in extra-objects

509 collect (let ((extra-object (make-instance (first extra-objects)

510 :pointer (call-constructor (first extra-objects)

511 nil))))

512 (set-binding extra-object)

513 (setf (get-object (pointer extra-object)) object)

514 extra-object)))

515

516 (defmethod initialize-instance :after ((object smoke-multi-superclass-mixin)

517 &key args)

518 (setf (slot-value object 'extra-objects)

519 (construct-extra-objects object (extra-objects object))))

520

521 (defmethod make-finalize ((object smoke-multi-superclass-mixin))

522 (let ((pointer (pointer object))

523 (extra-objects (extra-objects object))

524 (class (class-of object)))

525 #'(lambda ()

526 (declare (optimize (speed 3)))

527 (handler-case (progn

528 (delete-pointer pointer class)

529 (dolist (object extra-objects)

530 (delete-object object)))

531 (error (condition)

532 (report-finalize-error condition 't (name class) pointer))))))

533

534 (defmethod instance-to-lisp (pointer class type)

535 (declare (type smoke-standard-class class)

536 (optimize (speed 3)))

537 (let ((ret (make-instance class :pointer pointer

538 :const-p (const-p type))))

539 (when (stack-p type)

540 (take-ownership ret)

541 (add-object ret))

542 ret))

543

544 (defun keep-wrapper (object new-owner)

545 (declare (type smoke-standard-object object)

546 (optimize (speed 3)))

547 (when (member object (owned-objects new-owner))

548 (cerror "Ignore" "~A has already been added to ~A."

549 object new-owner))

550 (push object (owned-objects new-owner)))

551

552 (declaim (inline remove-wrapper-object))

553 (defun remove-wrapper-object (object owner)

554 (remove object (owned-objects owner)))

555

556 (defun transfer-ownership-to (object new-owner)

557 "Transfers the ownership of OBJECT to C++."

558 (declare (optimize (speed 3)))

559 (remove-finalizer object)

560 (if (virtual-destructor-p (class-of object))

561 (keep-wrapper object new-owner)

562 (remove-object (pointer object))))

563

564 (defun take-ownership (object &optional current-owner)

565 "Assigns the ownership of OBJECT to Lisp. i.e.:

566 cl-smoke is responsible for deleting the object."

567 (when current-owner

568 (remove-wrapper-object object current-owner))

569 (set-finalizer object))