chiark - git - mdw - clg/blob - gffi/interface.lisp

1 ;; Common Lisp bindings for GTK+ v2.x

3 ;;

4 ;; Permission is hereby granted, free of charge, to any person obtaining

5 ;; a copy of this software and associated documentation files (the

6 ;; "Software"), to deal in the Software without restriction, including

7 ;; without limitation the rights to use, copy, modify, merge, publish,

8 ;; distribute, sublicense, and/or sell copies of the Software, and to

9 ;; permit persons to whom the Software is furnished to do so, subject to

10 ;; the following conditions:

11 ;;

12 ;; The above copyright notice and this permission notice shall be

13 ;; included in all copies or substantial portions of the Software.

14 ;;

15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,

16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF

17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.

18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY

19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,

20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE

21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

22

23 ;; $Id: interface.lisp,v 1.10 2008-12-10 02:40:18 espen Exp $

24

25 (in-package "GFFI")

26

27

28 ;;;; Foreign function call interface

29

30 (defvar *package-prefix* nil)

31

32 (defun set-package-prefix (prefix &optional (package *package*))

33 (let ((package (find-package package)))

34 (setq *package-prefix* (delete package *package-prefix* :key #'car))

35 (push (cons package prefix) *package-prefix*))

36 prefix)

37

38 (defun package-prefix (&optional (package *package*))

39 (let ((package (find-package package)))

40 (or

41 (cdr (assoc package *package-prefix*))

42 (substitute #\_ #\- (string-downcase (package-name package))))))

43

44 (defun find-prefix-package (prefix)

45 (or

46 (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=))

47 (find-package (string-upcase prefix))))

48

49 (defmacro use-prefix (prefix &optional (package *package*))

50 `(eval-when (:compile-toplevel :load-toplevel :execute)

51 (set-package-prefix ,prefix ,package)))

52

53

54 (defun default-alien-fname (lisp-name)

55 (let* ((name (substitute #\_ #\- (string-downcase lisp-name)))

56 (start (position-if-not #'(lambda (char) (char= char #\%)) name))

57 (end (if (string= "_p" name :start2 (- (length name) 2))

58 (- (length name) 2)

59 (length name)))

60 (stripped-name (subseq name start end))

61 (prefix (package-prefix *package*)))

62 (if (or (not prefix) (string= prefix ""))

63 stripped-name

64 (format nil "~A_~A" prefix stripped-name))))

65

66 (defun default-alien-type-name (type-name)

67 (let ((prefix (package-prefix *package*)))

68 (apply

69 #'concatenate

70 'string

71 (mapcar

72 #'string-capitalize

73 (cons prefix (split-string (symbol-name type-name) :delimiter #\-))))))

74

75 (defun split-alien-name (alien-name)

76 (let ((parts (split-string-if alien-name #'upper-case-p)))

77 (do ((prefix (first parts) (concatenate 'string prefix (first rest)))

78 (rest (rest parts) (cdr rest)))

79 ((null rest)

80 (error "Couldn't split alien name '~A' to find a registered prefix"

81 alien-name))

82 (when (find-prefix-package prefix)

83 (return (values (string-upcase (concatenate-strings rest #\-))

84 (find-prefix-package prefix)))))))

85

86 (defun default-type-name (alien-name)

87 (multiple-value-call #'intern (split-alien-name alien-name)))

88

89 (defun in-arg-p (style)

90 (find style '(:in :in/out :in/return :in-out :return)))

91

92 (defun out-arg-p (style)

93 (find style '(:out :in/out :in-out)))

94

95 (defun return-arg-p (style)

96 (find style '(:in/return :return)))

97

98 (defmacro defbinding (name lambda-list return-type &rest args)

99 "This defines a foreign function call. NAME should either be a symbol or a

100 list (LISP-SYM STRING). The lisp function will be given the name of the lisp

101 symbol and the foreign function name is either the string given or automatically

102 generated using DEFAULT-ALIEN-FNAME.

103

104 If LAMBDA-LIST is nil, the lambda list for the generated lisp function is

105 automatically computed from the input arguments as described below. If it is

106 non-nil, it gives the lambda list for the function. To manually specify an empty

107 lambda list, pass (NIL) which gets recognised as a special value.

108

109 RETURN-TYPE should be a valid type.

110

111 A normal element of ARGS is a list matching

112

113 (EXPR TYPE &OPTIONAL (STYLE :IN) (OUT-TYPE TYPE))

114

115 however a shorthand form for an input parameter with name the same as its type

116 is that you can just give the atom TYPE as an argument. The lambda-list for the

117 function is the list of all input arguments, although if an EXPR is repeated, it

118 will only appear once. To add a constant argument, define one with STYLE :IN and

119 EXPR the value it should take.

120

121 To give the binding a docstring, pass a string as the first element of ARGS."

122 (multiple-value-bind (lisp-name c-name)

123 (if (atom name)

124 (values name (default-alien-fname name))

125 (values-list name))

126

127 (let* ((lambda-list-supplied-p lambda-list)

128 (lambda-list (unless (equal lambda-list '(nil)) lambda-list))

129 (arg-types ())

130 (aux-bindings ())

131 (doc-string (when (stringp (first args)) (pop args)))

132 (parsed-args

133 (mapcar

134 #'(lambda (arg)

135 (destructuring-bind

136 (expr type &optional (style :in) (out-type type))

137 (if (atom arg)

138 (list arg arg)

139 arg)

140 (cond

141 ((find style '(:in-out :return))

142 (warn "Deprecated argument style: ~S" style))

143 ((not (find style '(:in :out :in/out :in/return)))

144 (error "Bogus argument style: ~S" style)))

145 (when (and

146 (not lambda-list-supplied-p)

147 (namep expr) (in-arg-p style)

148 (not (find expr lambda-list)))

149 (push expr lambda-list)

150 (push type arg-types))

151 (let ((aux (unless (or (not (in-arg-p style)) (namep expr))

152 (gensym))))

153 (when aux

154 (push (list aux expr) aux-bindings))

155 (list

156 (cond

157 ((and (namep expr) (not (in-arg-p style))) expr)

158 ((namep expr)

159 #-clisp(make-symbol (string expr))

160 ;; The above used to work in CLISP, but I'm

161 ;; not sure exactly at which version it

162 ;; broke. The following could potentially

163 ;; cause variable capturing

164 #+clisp(intern (format nil "~A-~A" (string expr) (gensym))))

165 (#-clisp(gensym)

166 #+clisp(intern (string (gensym)))))

167 (or aux expr) type style out-type))))

168 args)))

169

170 (%defbinding c-name lisp-name

171 (if lambda-list-supplied-p lambda-list (nreverse lambda-list))

172 (not lambda-list-supplied-p) (nreverse arg-types)

173 aux-bindings return-type doc-string parsed-args))))

174

175

176 #+(or cmu sbcl)

177 (defun foreign-funcall (cname args return-type)

178 (let ((fparams (loop

179 for (var expr type style out-type) in args

180 collect (if (out-arg-p style)

181 `(addr ,var)

182 var)))

183 (ftypes (loop

184 for (var expr type style out-type) in args

185 collect (if (out-arg-p style)

186 `(* ,(alien-type out-type))

187 (alien-type out-type))))

188 (fname (make-symbol cname)))

189 `(with-alien ((,fname (function ,(alien-type return-type) ,@ftypes) :extern ,cname))

190 (alien-funcall ,fname ,@fparams))))

191

192 #+clisp

193 (defun foreign-funcall (cname args return-type)

194 (let* ((fparams (loop

195 for (var expr type style out-type) in args

196 collect (if (out-arg-p style)

197 `(ffi:c-var-address ,var)

198 var)))

199 (fargs (loop

200 for (var expr type style out-type) in args

201 collect (list var (if (out-arg-p style)

202 'ffi:c-pointer

203 (alien-type out-type)))))

204 (c-function `(ffi:c-function

205 (:arguments ,@fargs)

206 (:return-type ,(alien-type return-type))

207 (:language :stdc))))

208 `(funcall

209 (load-time-value

210 (ffi::foreign-library-function

211 ,cname (ffi::foreign-library :default) #?(clisp>= 2 40)nil

212 nil (ffi:parse-c-type ',c-function)))

213 ,@fparams)))

214

215

216 ;; TODO: check if in and out types (if different) translates to same

217 ;; alien type

218 (defun %defbinding (cname lisp-name lambda-list declare-p arg-types aux-bindings return-type doc args)

219 (let ((out (loop

220 for (var expr type style out-type) in args

221 when (or (out-arg-p style) (return-arg-p style))

222 collect (from-alien-form out-type var)))

223 (fcall (from-alien-form return-type

224 (foreign-funcall cname args return-type))))

225

226 (labels ((create-wrapper (args body)

227 (if args

228 (destructuring-bind (var expr type style out-type) (first args)

229 (declare (ignore out-type))

230 (alien-arg-wrapper type var expr style

231 (create-wrapper (rest args) body)))

232 body)))

233 `(progn

234 ,(when declare-p

235 `(declaim

236 (ftype

237 (function

238 ,(mapcar #'argument-type arg-types)

239 (values

240 ,@(when return-type (list (return-type return-type)))

241 ,@(loop

242 for (var expr type style out-type) in args

243 when (out-arg-p style)

244 collect (return-type out-type)

245 when (return-arg-p style)

246 collect (return-type type))))

247 ,lisp-name)))

248 (defun ,lisp-name ,lambda-list

249 ,doc

250 (let ,aux-bindings

251 ,(if return-type

252 (create-wrapper args `(values ,fcall ,@out))

253 (create-wrapper args `(progn ,fcall (values ,@out))))))))))

254

255

256

257 ;;;; Dynamic (runtime) bindings

258

259 (defun mkbinding (name return-type &rest arg-types)

260 #+cmu(declare (optimize (inhibit-warnings 3)))

261 #+sbcl(declare (muffle-conditions compiler-note))

262 (let* ((c-function

263 #+(or cmu sbcl)

264 `(function ,@(mapcar #'alien-type (cons return-type arg-types)))

265 #+clisp

266 `(ffi:c-function

267 (:arguments ,@(mapcar

268 #'(lambda (type)

269 (list (gensym) (alien-type type)))

270 arg-types))

271 (:return-type ,(alien-type return-type))

272 (:language :stdc)))

273 (foreign

274 #+(or cmu sbcl)

275 (handler-bind (#+sbcl(compiler-note #'(lambda (condition)

276 (declare (ignore condition))

277 (muffle-warning))))

278 (%heap-alien

279 (make-heap-alien-info

280 :type (parse-alien-type c-function #+sbcl nil)

281 :sap-form (let ((address (foreign-symbol-address name)))

282 (etypecase address

283 (integer (int-sap address))

284 (system-area-pointer address))))))

285 #+clisp

286 (ffi::foreign-library-function name

287 (ffi::foreign-library :default) #?(clisp>= 2 40)nil

288 nil (ffi:parse-c-type c-function)))

289 (return-value-translator (from-alien-function return-type)))

290 (multiple-value-bind (arg-translators cleanup-funcs)

291 (let ((translator/cleanup-pairs

292 (mapcar

293 #'(lambda (type)

294 (multiple-value-list (to-alien-function type)))

295 arg-types)))

296 (values

297 (mapcar #'first translator/cleanup-pairs)

298 (mapcar #'second translator/cleanup-pairs)))

299 #'(lambda (&rest args)

300 (let ((translated-args (mapcar #'funcall arg-translators args)))

301 (prog1

302 (funcall return-value-translator

303 #+(or cmu sbcl)(apply #'alien-funcall foreign translated-args)

304 #+clisp(apply foreign translated-args))

305 (mapc

306 #'(lambda (cleanup arg translated-arg)

307 (when cleanup

308 (funcall cleanup arg translated-arg)))

309 cleanup-funcs args translated-args)))))))

313 ;;;; C Callbacks

315 (defun callback-body (args return-type body)

316 (labels ((create-wrappers (args body)

317 (if args

318 (destructuring-bind (var type) (first args)

319 (callback-wrapper type var var

320 (create-wrappers (rest args) body)))

321 body))

322 (create-body (args body)

323 (to-alien-form return-type

324 (create-wrappers args `(progn ,@body)))))

325 (if (and (consp (first body)) (eq (caar body) 'declare))

326 (let ((ignored (loop

327 for declaration in (cdar body)

328 when (eq (first declaration) 'ignore)

329 nconc (rest declaration))))

330 `(,(first body)

331 ,(create-body

332 (remove-if #'(lambda (arg)

333 (find (first arg) ignored))

334 args)

335 (rest body))))

336 (list (create-body args body)))))

337

338

339 #+(or cmu sbcl)

340 (defmacro define-callback (name return-type args &body body)

341 (let ((define-callback

342 #+cmu'alien:def-callback

343 #+(and sbcl alien-callbacks)'sb-alien::define-alien-callback

344 #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function)

345 (args (mapcar #'(lambda (arg)

346 (if (atom arg) (list arg arg) arg))

347 args)))

348 `(progn

349 #+cmu(defparameter ,name nil)

350 (,define-callback ,name

351 #+(and sbcl alien-callbacks) ,(alien-type return-type)

352 (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type)

353 ,@(loop

354 for (name type) in args

355 collect `(,name ,(alien-type type))))

356 ,@(callback-body args return-type body)))))

357

358 #+(or cmu sbcl)

359 (defun callback-address (callback)

360 #+cmu(alien::callback-trampoline callback)

361 #+(and sbcl (not alien-callbacks))(sb-alien:alien-function-sap callback)

362 #+(and sbcl alien-callbacks)(sb-alien:alien-sap callback))

363

364 #+sbcl

365 (deftype callback ()

366 #-alien-callbacks'sb-alien:alien-function

367 #+alien-callbacks'sb-alien:alien)

368

369

370 ;;; The callback code for CLISP is based on code from CFFI

373

374

375 ;;; *CALLBACKS* contains the callbacks defined by the %DEFCALLBACK

376 ;;; macro. The symbol naming the callback is the key, and the value

377 ;;; is a list containing a Lisp function, the parsed CLISP FFI type of

378 ;;; the callback, and a saved pointer that should not persist across

379 ;;; saved images.

380 #+clisp

381 (progn

382 (defvar *callbacks* (make-hash-table))

383

384 ;;; Return a CLISP FFI function type for a CFFI callback function

385 ;;; given a return type and list of argument names and types.

386 (eval-when (:compile-toplevel :load-toplevel :execute)

387 (defun callback-type (return-type arg-names arg-types)

388 (ffi:parse-c-type

389 `(ffi:c-function

390 (:arguments ,@(mapcar (lambda (sym type)

391 (list sym (alien-type type)))

392 arg-names arg-types))

393 (:return-type ,(alien-type return-type))

394 (:language :stdc)))))

395

396 ;;; Register and create a callback function.

397 (defun register-callback (name function parsed-type)

398 (setf (gethash name *callbacks*)

399 (list function parsed-type

400 (ffi:with-foreign-object (ptr 'ffi:c-pointer)

401 ;; Create callback by converting Lisp function to foreign

402 (setf (ffi:memory-as ptr parsed-type) function)

403 (ffi:foreign-value ptr)))))

404

405 ;;; Restore all saved callback pointers when restarting the Lisp

406 ;;; image. This is pushed onto CUSTOM:*INIT-HOOKS*.

407 ;;; Needs clisp > 2.35, bugfix 2005-09-29

408 (defun restore-callback-pointers ()

409 (maphash

410 (lambda (name list)

411 (register-callback name (first list) (second list)))

412 *callbacks*))

413

414 ;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run

415 ;;; when an image is restarted.

416 (eval-when (:load-toplevel :execute)

417 (pushnew 'restore-callback-pointers custom:*init-hooks*))

418

419 ;;; Define a callback function NAME to run BODY with arguments

420 ;;; ARG-NAMES translated according to ARG-TYPES and the return type

421 ;;; translated according to RETTYPE. Obtain a pointer that can be

422 ;;; passed to C code for this callback by calling %CALLBACK.

423 (defmacro define-callback (name return-type args &body body)

424 (let* ((args (mapcar #'(lambda (arg)

425 (if (atom arg) (list arg arg) arg))

426 args))

427 (arg-names (mapcar #'first args))

428 (arg-types (mapcar #'second args)))

429 `(progn

430 (defvar ,name ',name)

431 (register-callback ',name

432 (lambda ,arg-names ,@(callback-body args return-type body))

433 ,(callback-type return-type arg-names arg-types)))))

434

435 ;;; Look up the name of a callback and return a pointer that can be

436 ;;; passed to a C function. Signals an error if no callback is

437 ;;; defined called NAME.

438 (defun callback-address (name)

439 (multiple-value-bind (list winp) (gethash name *callbacks*)

440 (unless winp

441 (error "Undefined callback: ~S" name))

442 (third list)))

443

444 (deftype callback () 'symbol))

445

446

447

448 ;;;; Type expansion

449

450 ;; A hack to make the TYPE-EXPAND code for SBCL work.

451 #?+(pkg-config:sbcl>= 1 0 35 15)

452 (sb-ext:without-package-locks

453 (setf (symbol-function 'sb-kernel::type-expand)

454 (lambda (form) (typexpand form))))

455

456 (defun type-expand-1 (form)

457 #+(or cmu sbcl)

458 (let ((def (cond ((symbolp form)

459 #+cmu(kernel::info type expander form)

460 #+sbcl(sb-impl::info :type :expander form))

461 ((and (consp form) (symbolp (car form)))

462 #+cmu(kernel::info type expander (car form))

463 #+sbcl(sb-impl::info :type :expander (car form)))

464 (t nil))))

465 (if def

466 (values (funcall def (if (consp form) form (list form))) t)

467 (values form nil)))

468 #+clisp(ext:type-expand form t))

469

470 (defun type-expand-to (type form)

471 (labels ((expand (form0)

472 (if (eq (first (mklist form0)) type)

473 form0

474 (multiple-value-bind (expanded-form expanded-p)

475 (type-expand-1 form0)

476 (if expanded-p

477 (expand expanded-form)

478 (error "~A can not be expanded to ~A" form type))))))

479 (expand form)))

480

481 (defun type-equal-p (type1 type2)

482 (and (subtypep type1 type2) (subtypep type2 type1)))

483

484

485 ;;;; Type methods

486

487 (defun find-type-method (name type-spec &optional (error-p t))

488 (let ((type-methods (get name 'type-methods))

489 (specifier (if (atom type-spec)

490 type-spec

491 (first type-spec))))

492 (or

493 (gethash specifier type-methods)

494 (when error-p

495 (error

496 "No explicit type method for ~A when call width type specifier ~A found"

497 name type-spec)))))

498

499 (defun find-next-type-method (name type-spec &optional (error-p t))

500 (let ((type-methods (get name 'type-methods)))

501 (labels ((search-method-in-cpl-order (classes)

502 (when classes

503 (or

504 (gethash (class-name (first classes)) type-methods)

505 (search-method-in-cpl-order (rest classes)))))

506 (lookup-method (type-spec)

507 (if (and (symbolp type-spec) (find-class type-spec nil))

508 (let ((class (find-class type-spec)))

509 #?(or (sbcl>= 0 9 15) (featurep :clisp))

510 (unless (class-finalized-p class)

511 (finalize-inheritance class))

512 (search-method-in-cpl-order

513 (rest (class-precedence-list class))))

514 (multiple-value-bind (expanded-type expanded-p)

515 (type-expand-1 type-spec)

516 (when expanded-p

517 (or

518 (let ((specifier (etypecase expanded-type

519 (symbol expanded-type)

520 (list (first expanded-type)))))

521 (gethash specifier type-methods))

522 (lookup-method expanded-type))))))

523 (search-built-in-type-hierarchy (sub-tree)

524 (when (subtypep type-spec (first sub-tree))

525 (or

526 (search-nodes (cddr sub-tree))

527 (second sub-tree))))

528 (search-nodes (nodes)

529 (loop

530 for node in nodes

531 as method = (search-built-in-type-hierarchy node)

532 until method

533 finally (return method))))

534 (or

535 (lookup-method type-spec)

536 ;; This is to handle unexpandable types whichs doesn't name a

537 ;; class. It may cause infinite loops with illegal

538 ;; call-next-method calls

539 (unless (or

540 (null type-spec)

541 (and (symbolp type-spec) (find-class type-spec nil)))

542 (search-nodes (get name 'built-in-type-hierarchy)))

543 (when error-p

544 (error "No next type method ~A for type specifier ~A"

545 name type-spec))))))

546

547 (defun find-applicable-type-method (name type-spec &optional (error-p t))

548 (or

549 (find-type-method name type-spec nil)

550 (find-next-type-method name type-spec nil)

551 (when error-p

552 (error

553 "No applicable type method for ~A when call width type specifier ~A"

554 name type-spec))))

555

556

557 (defun insert-type-in-hierarchy (specifier function nodes)

558 (cond

559 ((let ((node (find specifier nodes :key #'first)))

560 (when node

561 (setf (second node) function)

562 nodes)))

563 ((let ((node

564 (find-if

565 #'(lambda (node)

566 (subtypep specifier (first node)))

567 nodes)))

568 (when node

569 (setf (cddr node)

570 (insert-type-in-hierarchy specifier function (cddr node)))

571 nodes)))

572 ((let ((sub-nodes (remove-if-not

573 #'(lambda (node)

574 (subtypep (first node) specifier))

575 nodes)))

576 (cons

577 (list* specifier function sub-nodes)

578 (nset-difference nodes sub-nodes))))))

579

580 (defun add-type-method (name specifier function)

581 (setf (gethash specifier (get name 'type-methods)) function)

582 (when (typep (find-class specifier nil) 'built-in-class)

583 (setf (get name 'built-in-type-hierarchy)

584 (insert-type-in-hierarchy specifier function

585 (get name 'built-in-type-hierarchy)))))

586

587

588 (defmacro define-type-generic (name lambda-list &optional documentation)

589 (let ((type-spec (first lambda-list)))

590 (if (or

591 (not lambda-list)

592 (find type-spec '(&optional &key &rest &allow-other-keys)))

593 (error "A type generic needs at least one required argument")

594 `(progn

595 (unless (get ',name 'type-methods)

596 (setf (get ',name 'type-methods) (make-hash-table))

597 (setf (get ',name 'built-in-type-hierarchy) ()))

598 ,(if (intersection '(&optional &key &rest &allow-other-keys) lambda-list)

599 (let ((args (make-symbol "ARGS")))

600 `(defun ,name (,type-spec &rest ,args)

601 ,documentation

602 (apply

603 (find-applicable-type-method ',name ,type-spec)

604 ,type-spec ,args)))

605 `(defun ,name ,lambda-list

606 ,documentation

607 (funcall

608 (find-applicable-type-method ',name ,type-spec)

609 ,@lambda-list)))))))

610

611

612 (defmacro define-type-method (name lambda-list &body body)

613 (let ((specifier (cadar lambda-list))

614 (args (make-symbol "ARGS")))

615 `(progn

616 (add-type-method ',name ',specifier

617 #'(lambda (&rest ,args)

618 (flet ((call-next-method (&rest args)

619 (let ((next-method (find-next-type-method ',name ',specifier)))

620 (apply next-method (or args ,args)))))

621 (destructuring-bind (,(caar lambda-list) ,@(rest lambda-list)) ,args

622 ,@body))))

623 ',name)))

624

625

626 ;;; Rules for auto-exporting symbols

627

628 (defexport defbinding (name &rest args)

629 (declare (ignore args))

630 (if (symbolp name)

631 name

632 (first name)))

633

634 (defexport define-type-generic (name &rest args)

635 (declare (ignore args))

636 name)