darcs - smoke

1 ;;; C++ overload resolution

2 ;;; See: http://www.open-std.org/jtc1/sc22/wg21/docs/papers/2008/n2800.pdf

3 ;;;

4 ;;; We handle only the most common cases. Stuff like virtual inheritance

5 ;;; that is not needed is not implemented.

7 (in-package :smoke)

9 (declaim (inline cmp))

10 (defun cmp (a b)

11 (- a b))

13 (declaim (inline strcmp))

14 (defcfun strcmp :int (s1 :pointer) (s2 :pointer))

16 (declaim (inline cstring/=))

17 (defun cstring/= (string1 string2)

18 "Returns T when the C strings STRING1 and STRING2 are not equal

19 and NIL otherwise."

20 (not (zerop (strcmp string1 string2))))

22 (defun method-cmp (method class-id name)

23 "Compares METHOD to the method with NAME of class CLASS-ID."

24 (declare (foreign-pointer name)

25 (type (smoke-index 0) class-id)

26 (smoke-method method)

27 (optimize (speed 3) (debug 0) (safety 0)))

28 (let ((id-cmp (cmp (the (smoke-index 0) (method-slot-value method 'class))

29 (the (smoke-index 0) class-id))))

30 (declare (type smoke-index id-cmp))

31 (if (/= 0 id-cmp)

32 id-cmp

33 (strcmp (smoke-method-name method)

34 name))))

36 (declaim (inline first-unabigious-index))

37 (defun first-unabigious-index (smoke index)

38 (declare (type smoke-index index)

39 (optimize (speed 3)))

40 (if (>= index 0)

41 index

42 (mem-aref (smoke-module-ambiguous-method-list smoke)

43 'smoke-index

44 (- index))))

46 (defun find-method-for-class (name class)

47 "Returns the index of a method with name NAME for class CLASS."

48 (declare (type foreign-pointer name)

49 (type smoke-class class)

50 (optimize (speed 3)))

51 (let* ((start 1) ;; 0 is "no method"

52 (class-id (id class))

53 (smoke (smoke class))

54 (end (1+ (smoke-array-length (smoke-module-method-maps smoke)))))

55 (declare (type (smoke-index 0) start end)

56 (dynamic-extent start))

57 (loop until (> start end) do

58 (let* ((index (the smoke-index (floor (+ end start) 2)))

59 (method (make-smoke-method

60 :smoke smoke

61 :id (the (smoke-index 0)

62 (first-unabigious-index

63 smoke

64 (foreign-slot-value

65 (mem-aref (smoke-array-pointer

66 (smoke-module-method-maps

67 smoke))

68 'smoke-method-map index)

69 'smoke-method-map

70 'method)))))

71 (cmp (the smoke-index (method-cmp method class-id name))))

72 (declare (type smoke-index cmp)

73 (dynamic-extent method))

74 (if (< cmp 0)

75 (setf start (1+ index))

76 (if (> cmp 0)

77 (setf end (1- index))

78 (return-from find-method-for-class index))))))

79 -1)

81 (defmacro push-candidate-method (index name argument-count class methods

82 const-p)

83 (with-gensyms (method-map method-index method ambig-index i smoke)

84 `(let* ((,smoke (smoke ,class))

85 (,method-map (mem-aref

86 (smoke-array-pointer

87 (smoke-module-method-maps ,smoke))

88 'smoke-method-map

89 (the smoke-index ,index)))

90 (,method-index (foreign-slot-value ,method-map 'smoke-method-map 'method))

91 (,method (make-smoke-method

92 :smoke ,smoke

93 :id (first-unabigious-index

94 ,smoke

95 ,method-index))))

96 (declare (type smoke-index ,method-index))

97 (if (cstring/= ,name

98 (smoke-method-name ,method))

99 nil

100 (progn

101 (when (= (the smoke-index ,argument-count)

102 (the smoke-index (get-arguments-length ,method)))

103 (if (< ,method-index 0)

104 (let ((,ambig-index (- ,method-index)))

105 (declare (type smoke-index ,ambig-index))

106 (loop as ,i = (the smoke-index

107 (mem-aref (smoke-module-ambiguous-method-list

108 ,smoke)

109 'smoke-index

110 ,ambig-index))

111 while (> (the smoke-index ,i) 0) do

112 (incf ,ambig-index)

113 (let ((,method (make-smoke-method :smoke ,smoke

114 :id ,i)))

115 (unless (and ,const-p (not (const-p ,method)))

116 (push ,method ,methods)))))

117 (unless (and ,const-p (not (const-p ,method)))

118 (push ,method ,methods))))

119 t)))))

120

121 (defun viable-functions (name argument-count class &optional const-p)

122 (declare (optimize (speed 3)))

123 (with-foreign-string (name name)

124 (let ((methods))

125 (let ((smoke (smoke class)))

126 (let ((start-index (find-method-for-class name class)))

127 (declare (type smoke-index start-index))

128 (when (>= start-index 0)

129 (loop for index from start-index downto 1

130 while (push-candidate-method index name argument-count class

131 methods const-p))

132 (loop for index from (1+ start-index)

133 to (the smoke-index (smoke-array-length

134 (smoke-module-method-maps smoke)))

135 while (push-candidate-method index name argument-count class

136 methods const-p)))))

137 methods)))

138

139 (declaim (inline make-conversion make-exact-match make-promotion

140 make-number-conversion make-pointer-conversion

141 make-boolean-conversion make-user-conversion))

142 (defstruct conversion

143 (function-name nil :type (or symbol list function) :read-only t)

144 (rank -1 :type fixnum :read-only t))

145

146 (defstruct (exact-match (:include conversion (rank 0))))

147

148 (defstruct (promotion (:include conversion (rank 1))))

149

150 (defstruct (number-conversion (:include conversion (rank 2))))

151

152 (defstruct (pointer-conversion (:include conversion (rank 3)))

153 (from (find-class t) :type class :read-only t)

154 (to (find-class t) :type class :read-only t))

155

156 (defstruct (boolean-conversion (:include conversion (rank 4))))

157

158 (defstruct (user-conversion (:include conversion (rank 5))))

159

160 (defgeneric conversion<= (conversion1 conversion2)

161 ;; 13.3.3.2 Ranking implicit conversion sequences

162 ;; 4

163 (:method (conversion1 conversion2)

164 (declare (optimize (speed 3)))

165 (and (not (null conversion1))

166 (or (null conversion2)

167 (<= (the fixnum (conversion-rank conversion1))

168 (the fixnum (conversion-rank conversion2))))))

169 (:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion))

170 (declare (optimize (speed 3)))

171 (if (eq (pointer-conversion-from conversion1)

172 (pointer-conversion-from conversion2))

173 ;; A->B < A->C <=> B subclass of C

174 (subtypep (pointer-conversion-to conversion1)

175 (pointer-conversion-to conversion2))

176 (if (eq (pointer-conversion-to conversion1)

177 (pointer-conversion-to conversion2))

178 ;; B->A < C->A <=> B subclass of C

179 (subtypep (pointer-conversion-from conversion1)

180 (pointer-conversion-from conversion2))

181 nil))))

182

183 (defgeneric conversion= (conversion1 conversion2)

184 (:method (conversion1 conversion2)

185 (and (conversion<= conversion1 conversion2)

186 (conversion<= conversion2 conversion1)))

187 (:method ((conversion1 (eql nil)) (conversion2 (eql nil)))

188 t))

189

190 (defun max-conversion (conversion1 conversion2)

191 "Returns the greater conversion of CONVERSION1 and CONVERSION2."

192 (if (null conversion2)

193 conversion1

194 (if (conversion<= conversion1 conversion2)

195 conversion2

196 conversion1)))

197

198 (defmacro make-match (type &optional (name ''identity) (argument nil)

199 &rest args)

200 (flet ((conversion-function (name &optional arg)

201 (if arg

202 `(if (using-typep)

203 `(,,name

204 ,(if (typep ,arg 'class)

205 `(find-class ',(class-name ,arg))

206 `(find-smoke-method (find-class ,(class-name

207 (find-smoke-class

208 (get-class ,arg))))

209 ,(name ,arg))))

210 #'(lambda (object)

211 (funcall (fdefinition ,name)

212 object ,arg)))

213 `(if (using-typep)

214 ,name

215 (fdefinition ,name)))))

216 `(,(symbolicate 'make- (eval type))

217 :function-name ,(conversion-function name argument)

218 ,@args)))

219

220 (defun+using-type get-conversion-sequence object (object type &optional user)

221 "Retrains a conversion sequence to convert a instance of type CLASS

222 to an instance of type TYPE. When USER is true user conversions are considered."

223 (if-let (match (call-using-type exact-match object type))

224 (if (eql t match)

225 (make-match 'exact-match)

226 (make-match 'exact-match match))

227 (or (call-using-type promotion object type)

228 (call-using-type conversion object type)

229 (and user

230 (call-using-type user-conversion object type)))))

231

232 (defun+using-types standard-conversion-sequence (method classes &optional user)

233 "Returns the conversion sequences to convert the arguments of types CLASSES

234 to the types required by METHOD."

235 (if (null classes)

236 (values (make-match 'exact-match) nil)

237 (let ((max-rank)

238 (conversions))

239 (loop for type in (arguments method)

240 for class in classes do

241 (let ((rank (call-using-type get-conversion-sequence class type user)))

242 (when (null rank)

243 (setf max-rank nil)

244 (return nil))

245 (setf max-rank (max-conversion rank max-rank))

246 (push (conversion-function-name rank) conversions)))

247 (values max-rank (reverse conversions)))))

248

249 (defun+using-types conversion-sequence (method classes)

250 (call-using-types standard-conversion-sequence method classes t))

251

252 (defun+using-types find-best-viable-function (name arguments class

253 &optional const-p)

254 "Returns the method named NAME of class CLASS that can be called

255 using arguments of types TYPES with the lowest conversion sequence."

256 (call-using-types find-best-viable-function2

257 (function-using-types conversion-sequence)

258 name arguments class const-p))

259

260 (defun+using-types find-best-viable-function2 (get-sequence name objects class

261 &optional const-p)

262 (when (and (using-typep)

263 (not (typep class 'smoke-standard-class)))

264 (throw 'unspecific-type class))

265 (let ((viable-functions (viable-functions name (length objects)

266 class const-p))

267 (best-rank)

268 (best-method)

269 (conversions))

270 (if (null viable-functions)

271 (dolist (class (closer-mop:class-direct-superclasses class)

272 (values best-method nil))

273 (when (typep class 'smoke-standard-class)

274 (multiple-value-bind (method conversions)

275 (call-using-types find-best-viable-function2 get-sequence name objects class const-p)

276 (when method

277 (return (values method conversions))))))

278 (loop for method in viable-functions

279 finally (return (values best-method conversions)) do

280 (block next

281 (multiple-value-bind (rank method-conversions)

282 (funcall get-sequence method objects)

283 (when (and rank (conversion<= rank best-rank))

284 (when (conversion= rank best-rank)

285 ;; FIXME catch all ambigious overloads

286 (if const-p

287 (error "Ambigious overload ~A." method)

288 (when (const-p method)

289 ;; assume that the previous method is a non

290 ;; const one and thus more specific.

291 (return-from next))))

292 (setf best-rank rank)

293 (setf best-method method)

294 (setf conversions method-conversions)

295 (when (and (conversion= rank (make-match 'exact-match))

296 (not (xor const-p (const-p method))))

297 (return (values method conversions))))))))))

298

299 (defvar *from-lisp-translations* (make-hash-table :test 'equal))

300

301 (defmacro define-from-lisp-translation (type-names lisp-type

302 &optional

303 (conversion-function-name 'identity))

304 "Defines a translation from LISP-TYPE to the C++ types TYPE-NAMES using

305 the function CONVERSION-FUNCTION-NAME."

306 `(progn ,@(loop for type-name in (ensure-list type-names)

307 collect `(setf (gethash ,type-name *from-lisp-translations*)

308 #'(lambda (type type-p)

309 (and (if type-p

310 (multiple-value-bind (value valid-p)

311 (subtypep type ',lisp-type)

312 (unless valid-p

313 (throw 'unspecific-type type))

314 value)

315 (typep type ',lisp-type))

316 ',conversion-function-name))))))

317

318 (define-from-lisp-translation ("void*" "const void*" "void**" "const void**")

319 foreign-pointer)

320

321 ;; FIXME grovel this?

322 (deftype c-integer (ctype)

323 (let ((bits (* 8 (foreign-type-size ctype))))

324 (if (starts-with-subseq

325 (symbol-name :unsigned)

326 (symbol-name ctype))

327 `(unsigned-byte ,bits)

328 `(signed-byte ,bits))))

329

330

331 (defun+using-type exact-match object (object type)

332 "Test for an exact match."

333 (case (type-id type)

334 (0 (when-let (test (gethash (name type) *from-lisp-translations*))

335 (funcall test object (using-typep))))

336 (1 (object.typep 'boolean))

337 (2 (object.typep 'standard-char))

338 (3 (object.typep '(c-integer :unsigned-char)))

339 (4 (object.typep '(c-integer :short)))

340 (5 (object.typep '(c-integer :unsigned-short)))

341 (6 (object.typep '(c-integer :int)))

342 (7 (object.typep '(c-integer :unsigned-int)))

343 (8 (object.typep '(and (c-integer :long)

344 (not (c-integer :int)))))

345 (9 (object.typep '(and (c-integer :unsigned-long)

346 (not (c-integer :unsigned-int)))))

347 (10 (object.typep 'single-float))

348 (11 (object.typep 'double-float))

349 (12 (when (object.typep 'enum)

350 (when (using-typep)

351 (throw 'unspecific-type object))

352 (smoke-type= type (enum-type object))))

353 (13 (and (object.typep 'smoke-standard-object)

354 (smoke-type= (get-class type) (object.type-of))))))

355

356

357 (defun make-cleanup-pointer (pointer cleanup-function)

358 "Returns a pointer that calls CLEANUP-FUNCTION with pointer as argument

359 when it is finalized."

360 (let ((address (pointer-address pointer)))

361 (tg:finalize pointer #'(lambda ()

362 (funcall cleanup-function

363 (make-pointer address))))))

364

365 (defun make-auto-pointer (pointer)

366 "Returns a pointer that frees the memory at POINTER when it is finalized."

367 (make-cleanup-pointer pointer #'foreign-free))

368

369 (defun coerce-c-string (string)

370 (make-auto-pointer (foreign-string-alloc string)))

371

372 (defun coerce-from-enum (enum)

373 (cxx-support:value enum))

374

375 (defun coerce-double-float (number)

376 (float number 0d0))

377

378 (defun coerce-single-float (number)

379 (float number 0f0))

380

381 (defun coerce-to-enum (number)

382 ;; we can skip the enum type because it is not checked at this

383 ;; point.

384 (make-instance 'enum :value number))

385

386 ;; FIXME incomplete

387 (defun+using-type promotion object (object type)

388 (declare (smoke-type type))

389 (case (type-id type)

390 (0 (when (and (string= (name type) "const char*")

391 (object.typep 'string))

392 (make-match 'promotion 'coerce-c-string)))

393 (6 (when (object.typep 'enum)

394 (make-match 'promotion 'coerce-from-enum)))

395 (7 (when (object.typep 'enum)

396 (make-match 'promotion 'coerce-from-enum)))

397 (10 (when (object.typep 'real)

398 (make-match 'promotion 'coerce-single-float)))

399 (11 (when (object.typep 'real)

400 (make-match 'promotion 'coerce-double-float)))

401 (12 (when (object.typep '(integer 0))

402 (make-match 'promotion 'coerce-to-enum)))))

403

404 (declaim (inline coerce-to-class))

405 (defun coerce-cast (object to-class)

406 (cast object to-class))

407

408 (defun coerce-to-void (object)

409 object)

410

411 (defun+using-type conversion-cast object (object type)

412 (when (and (class-p type)

413 (object.typep 'smoke-standard-object)

414 (derived-p (object.type-of) (get-class type))

415 (find-smoke-class (get-class type)))

416 (make-match 'pointer-conversion

417 'coerce-cast

418 (find-smoke-class (get-class type))

419 :from (object.type-of)

420 :to (find-smoke-class (get-class type)))))

421

422 (defun+using-type conversion-void object (object type)

423 (when (and (string= (name type) "void*")

424 (object.typep 'smoke-standard-object))

425 (make-match 'pointer-conversion

426 'coerce-void

427 nil

428 :from (object.type-of)

429 :to (find-class 't))))

430

431 (defun+using-type conversion-pointer object (object type)

432 ;; Not using pointer-p to allow passing a raw pointer for objects on

433 ;; the stack and references.

434 ;; (e.g.: for qInstallMsgHandler(QtMsgHandler) )

435 ;;

436 ;; FIXME this breaks passing pointers to references.

437 ;;

438 ;; e.g.: calling the function foo(QByteArray& foo) with

439 ;; (foo pointer) assumes pointer to point to a QByteArray, but

440 ;; actually the conversion sequence QByteArray(pointer) should be

441 ;; used. When pointer is a null pointer it fails horribly!.

442 ;;

443 ;; But it is needed for passing the int pointer in QApplication(int&, char**).

444 (when (and (or (= 0 (type-id type)) ; voidp

445 (= 13 (type-id type))) ; class

446 (object.typep 'foreign-pointer))

447 (make-match 'pointer-conversion 'identity nil

448 :from (find-class 't)

449 :to (find-class 't)))) ;; FIXME get the class when applicable

450

451

452 (defun+using-type conversion object (object type)

453 (or (call-using-type conversion-cast object type)

454 (call-using-type conversion-void object type)

455 (call-using-type conversion-pointer object type)))

456

457 (defun+using-type user-conversion object (object type)

458 (or (call-using-type operator-conversion object type)

459 (call-using-type constructor-conversion object type)))

460

461 (defun conversion-operator-name (to-type)

462 (concatenate 'string

463 "operator "

464 (if (class-p to-type)

465 (name (get-class to-type))

466 (name to-type))))

467

468 (defun coerce-to-type (object method)

469 (pointer-call method (pointer object)))

470

471 (defun+using-type operator-conversion object (object type)

472 (when (object.typep 'smoke-standard-object)

473 (let ((method (find-smoke-method (object.type-of)

474 (conversion-operator-name type))))

475 (when (valid-p method)

476 (if (pointer-p type)

477 (make-match 'user-conversion

478 'coerce-to-type

479 method)

480 (make-match 'user-conversion

481 (lispify (name method) :cxx)))))))

482

483 (declaim (inline coerce-to-class))

484 (defun coerce-to-class (object to-class)

485 (make-instance to-class

486 :args (list object)))

487

488 (defun+using-type constructor-conversion object (object type)

489 (when (class-p type)

490 (handler-case

491 (let ((to-class (find-smoke-class (get-class type) nil)))

492 (when (and to-class

493 (call-using-types find-best-viable-function2

494 (if (using-typep)

495 #'standard-conversion-sequence-using-types

496 #'standard-conversion-sequence)

497 (constructor-name (get-class type))

498 (list object) to-class))

499 (make-match 'user-conversion

500 'coerce-to-class

501 to-class)))

502 ;; When the correspoinding Lisp module is not loaded, we ignore

503 ;; the overload.

504 (lisp-module-not-loaded ()))))

505

506 (defun call-sequence (method object sequence &rest args)

507 (s-call method object

508 (mapcar #'(lambda (conversion argument)

509 (funcall conversion argument))

510 sequence args)))

511

512 (defun format-no-applicable-cxx-method (stream name class arguments)

513 (format stream

514 "No applicable method ~S of ~A for ~S.

515 Candidates are:~{~T~A~%~}."

516 name class arguments

517 (mapcar #'signature

518 (viable-functions name

519 (length arguments)

520 (smoke-class-of class)))))

521

522 (define-condition no-applicable-cxx-method (error)

523 ((method :initarg :method :reader condition-method)

524 (class :initarg :class :reader condition-class)

525 (arguments :initarg :arguments :reader condition-arguments))

526 (:report (lambda (condition stream)

527 (format-no-applicable-cxx-method stream

528 (condition-method condition)

529 (condition-class condition)

530 (condition-arguments condition)))))

531

532 (defun call-using-args (object-or-class name arguments)

533 "Calls the method NAME of OBJECT-OR-CLASS with ARGUMENTS."

534 (declare (optimize (speed 3))

535 (type (or smoke-standard-class smoke-standard-object)

536 object-or-class))

537 (multiple-value-bind (method sequence)

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

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

540 name

541 arguments

542 (smoke-class-of object-or-class)

543 (when (typep object-or-class

544 'smoke-standard-object)

545 (const-p object-or-class)))

546 (when (null method)

547 (error (make-condition 'no-applicable-cxx-method

548 :method name

549 :class object-or-class

550 :arguments arguments)))

551 (apply #'call-sequence method

552 (if (static-p method)

553 (null-pointer)

554 (cast object-or-class (get-class method)))

555 sequence arguments)))

556

557 (defmethod slot-missing (meta-class (class smoke-standard-class) slot-name operation &optional new-value)

558 (let ((method (find-smoke-method class (lisp-to-cxx (string slot-name)))))

559 (if (or (not (valid-p method)) (not (static-p method)))

560 (call-next-method)

561 (ecase operation

562 (setf

563 (handler-case (funcall (fdefinition

564 (intern

565 (concatenate 'string "SET-"

566 (string-upcase

567 (string slot-name)))

568 :cxx))

569 class new-value)

570 (undefined-function ()

571 (error "The C++ attribute ~A of ~A is read only." slot-name class))

572 (no-applicable-cxx-method (condition)

573 (if (null (viable-functions (condition-method condition)

574 (length (condition-arguments condition))

575 (condition-class condition)))

576 (error "The C++ attribute ~A of ~A is read only." slot-name class)

577 (error condition)))))

578 (slot-boundp t)

579 (slot-makunbound (error "Can not unbind the C++ attribute ~A of ~A." slot-name class))

580 (slot-value (s-call method (null-pointer)))))))

581

582 (defmethod slot-missing ((class smoke-standard-class) object slot-name operation &optional new-value)

583 (let ((method (find-smoke-method class (lisp-to-cxx (string slot-name)))))

584 (if (not (valid-p method))

585 (call-next-method)

586 (ecase operation

587 (setf

588 (handler-case (funcall (fdefinition

589 (intern

590 (concatenate 'string "SET-"

591 (string-upcase

592 (string slot-name)))

593 :cxx))

594 object new-value)

595 (undefined-function ()

596 (error "The C++ attribute ~A of ~A is read only." slot-name object))

597 (no-applicable-cxx-method (condition)

598 (if (null (viable-functions (condition-method condition)

599 (length (condition-arguments condition))

600 (condition-class condition)))

601 (error "The C++ attribute ~A of ~A is read only." slot-name object)

602 (error condition)))))

603 (slot-boundp t)

604 (slot-makunbound (error "Can not unbind the C++ attribute ~A of ~A." slot-name object))

605 (slot-value (s-call method (cast object (get-class method))))))))