chiark / gitweb /
Bug fix (function name included in declarations)
[clg] / gffi / interface.lisp
CommitLineData
beae6579 1;; Common Lisp bindings for GTK+ v2.x
2;; Copyright 1999-2006 Espen S. Johnsen <espen@users.sf.net>
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
cab97f15 23;; $Id: interface.lisp,v 1.9 2008-10-08 16:34:07 espen Exp $
beae6579 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)))
49ef0cdc 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))
beae6579 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 default-type-name (alien-name)
76 (let ((parts
77 (mapcar
78 #'string-upcase
79 (split-string-if alien-name #'upper-case-p))))
80 (intern
81 (concatenate-strings (rest parts) #\-)
82 (find-prefix-package (first parts)))))
83
84
85(defun in-arg-p (style)
86 (find style '(:in :in/out :in/return :in-out :return)))
87
88(defun out-arg-p (style)
89 (find style '(:out :in/out :in-out)))
90
91(defun return-arg-p (style)
92 (find style '(:in/return :return)))
93
94(defmacro defbinding (name lambda-list return-type &rest args)
95 (multiple-value-bind (lisp-name c-name)
96 (if (atom name)
97 (values name (default-alien-fname name))
98 (values-list name))
99
100 (let* ((lambda-list-supplied-p lambda-list)
101 (lambda-list (unless (equal lambda-list '(nil)) lambda-list))
2c708568 102 (arg-types ())
103 (aux-bindings ())
beae6579 104 (doc-string (when (stringp (first args)) (pop args)))
105 (parsed-args
106 (mapcar
107 #'(lambda (arg)
108 (destructuring-bind
2c708568 109 (expr type &optional (style :in) (out-type type))
110 (if (atom arg)
111 (list arg arg)
112 arg)
beae6579 113 (cond
114 ((find style '(:in-out :return))
115 (warn "Deprecated argument style: ~S" style))
116 ((not (find style '(:in :out :in/out :in/return)))
117 (error "Bogus argument style: ~S" style)))
118 (when (and
119 (not lambda-list-supplied-p)
2c708568 120 (namep expr) (in-arg-p style)
121 (not (find expr lambda-list)))
122 (push expr lambda-list)
123 (push type arg-types))
beae6579 124 (let ((aux (unless (or (not (in-arg-p style)) (namep expr))
125 (gensym))))
126 (when aux
2c708568 127 (push (list aux expr) aux-bindings))
beae6579 128 (list
129 (cond
130 ((and (namep expr) (not (in-arg-p style))) expr)
02198d7d 131 ((namep expr)
132 #-clisp(make-symbol (string expr))
133 ;; The above used to work in CLISP, but I'm
134 ;; not sure exactly at which version it
135 ;; broke. The following could potentially
136 ;; cause variable capturing
137 #+clisp(intern (format nil "~A-~A" (string expr) (gensym))))
138 (#-clisp(gensym)
139 #+clisp(intern (string (gensym)))))
beae6579 140 (or aux expr) type style out-type))))
141 args)))
142
143 (%defbinding c-name lisp-name
144 (if lambda-list-supplied-p lambda-list (nreverse lambda-list))
2c708568 145 (not lambda-list-supplied-p) (nreverse arg-types)
146 aux-bindings return-type doc-string parsed-args))))
beae6579 147
148
149#+(or cmu sbcl)
150(defun foreign-funcall (cname args return-type)
151 (let ((fparams (loop
152 for (var expr type style out-type) in args
153 collect (if (out-arg-p style)
154 `(addr ,var)
155 var)))
156 (ftypes (loop
157 for (var expr type style out-type) in args
158 collect (if (out-arg-p style)
159 `(* ,(alien-type out-type))
160 (alien-type out-type))))
161 (fname (make-symbol cname)))
162 `(with-alien ((,fname (function ,(alien-type return-type) ,@ftypes) :extern ,cname))
163 (alien-funcall ,fname ,@fparams))))
164
165#+clisp
166(defun foreign-funcall (cname args return-type)
167 (let* ((fparams (loop
168 for (var expr type style out-type) in args
169 collect (if (out-arg-p style)
170 `(ffi:c-var-address ,var)
171 var)))
172 (fargs (loop
173 for (var expr type style out-type) in args
174 collect (list var (if (out-arg-p style)
175 'ffi:c-pointer
176 (alien-type out-type)))))
177 (c-function `(ffi:c-function
178 (:arguments ,@fargs)
179 (:return-type ,(alien-type return-type))
180 (:language :stdc))))
181 `(funcall
182 (load-time-value
4f2a8644 183 (ffi::foreign-library-function
184 ,cname (ffi::foreign-library :default) #?(clisp>= 2 40)nil
beae6579 185 nil (ffi:parse-c-type ',c-function)))
186 ,@fparams)))
187
188
189;; TODO: check if in and out types (if different) translates to same
190;; alien type
2c708568 191(defun %defbinding (cname lisp-name lambda-list declare-p arg-types aux-bindings return-type doc args)
beae6579 192 (let ((out (loop
193 for (var expr type style out-type) in args
194 when (or (out-arg-p style) (return-arg-p style))
195 collect (from-alien-form out-type var)))
196 (fcall (from-alien-form return-type
197 (foreign-funcall cname args return-type))))
198
199 (labels ((create-wrapper (args body)
200 (if args
201 (destructuring-bind (var expr type style out-type) (first args)
202 (declare (ignore out-type))
203 (alien-arg-wrapper type var expr style
204 (create-wrapper (rest args) body)))
205 body)))
2c708568 206 `(progn
207 ,(when declare-p
208 `(declaim
209 (ftype
210 (function
211 ,(mapcar #'argument-type arg-types)
212 (values
213 ,@(when return-type (list (return-type return-type)))
214 ,@(loop
215 for (var expr type style out-type) in args
216 when (out-arg-p style)
217 collect (return-type out-type)
218 when (return-arg-p style)
cab97f15 219 collect (return-type type))))
220 ,lisp-name)))
2c708568 221 (defun ,lisp-name ,lambda-list
beae6579 222 ,doc
2c708568 223 (let ,aux-bindings
beae6579 224 ,(if return-type
225 (create-wrapper args `(values ,fcall ,@out))
2c708568 226 (create-wrapper args `(progn ,fcall (values ,@out))))))))))
beae6579 227
228
229
230;;;; Dynamic (runtime) bindings
231
232(defun mkbinding (name return-type &rest arg-types)
233 #+cmu(declare (optimize (inhibit-warnings 3)))
234 #+sbcl(declare (muffle-conditions compiler-note))
235 (let* ((c-function
236 #+(or cmu sbcl)
237 `(function ,@(mapcar #'alien-type (cons return-type arg-types)))
238 #+clisp
239 `(ffi:c-function
240 (:arguments ,@(mapcar
241 #'(lambda (type)
242 (list (gensym) (alien-type type)))
243 arg-types))
244 (:return-type ,(alien-type return-type))
245 (:language :stdc)))
246 (foreign
247 #+(or cmu sbcl)
248 (handler-bind (#+sbcl(compiler-note #'(lambda (condition)
249 (declare (ignore condition))
250 (muffle-warning))))
251 (%heap-alien
252 (make-heap-alien-info
253 :type (parse-alien-type c-function #+sbcl nil)
254 :sap-form (let ((address (foreign-symbol-address name)))
255 (etypecase address
256 (integer (int-sap address))
257 (system-area-pointer address))))))
258 #+clisp
259 (ffi::foreign-library-function name
4f2a8644 260 (ffi::foreign-library :default) #?(clisp>= 2 40)nil
beae6579 261 nil (ffi:parse-c-type c-function)))
262 (return-value-translator (from-alien-function return-type)))
263 (multiple-value-bind (arg-translators cleanup-funcs)
264 (let ((translator/cleanup-pairs
265 (mapcar
266 #'(lambda (type)
267 (multiple-value-list (to-alien-function type)))
268 arg-types)))
269 (values
270 (mapcar #'first translator/cleanup-pairs)
271 (mapcar #'second translator/cleanup-pairs)))
272 #'(lambda (&rest args)
273 (let ((translated-args (mapcar #'funcall arg-translators args)))
274 (prog1
275 (funcall return-value-translator
276 #+(or cmu sbcl)(apply #'alien-funcall foreign translated-args)
277 #+clisp(apply foreign translated-args))
278 (mapc
279 #'(lambda (cleanup arg translated-arg)
280 (when cleanup
281 (funcall cleanup arg translated-arg)))
282 cleanup-funcs args translated-args)))))))
283
284
285
286;;;; C Callbacks
287
288(defun callback-body (args return-type body)
289 (labels ((create-wrappers (args body)
290 (if args
291 (destructuring-bind (var type) (first args)
292 (callback-wrapper type var var
293 (create-wrappers (rest args) body)))
294 body))
295 (create-body (args body)
296 (to-alien-form return-type
297 (create-wrappers args `(progn ,@body)))))
298 (if (and (consp (first body)) (eq (caar body) 'declare))
299 (let ((ignored (loop
300 for declaration in (cdar body)
301 when (eq (first declaration) 'ignore)
302 nconc (rest declaration))))
303 `(,(first body)
304 ,(create-body
305 (remove-if #'(lambda (arg)
306 (find (first arg) ignored))
307 args)
308 (rest body))))
309 (list (create-body args body)))))
310
311
312#+(or cmu sbcl)
313(defmacro define-callback (name return-type args &body body)
314 (let ((define-callback
315 #+cmu'alien:def-callback
316 #+(and sbcl alien-callbacks)'sb-alien::define-alien-callback
c52ab022 317 #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function)
318 (args (mapcar #'(lambda (arg)
319 (if (atom arg) (list arg arg) arg))
320 args)))
beae6579 321 `(progn
322 #+cmu(defparameter ,name nil)
323 (,define-callback ,name
324 #+(and sbcl alien-callbacks) ,(alien-type return-type)
325 (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type)
326 ,@(loop
327 for (name type) in args
328 collect `(,name ,(alien-type type))))
329 ,@(callback-body args return-type body)))))
330
331#+(or cmu sbcl)
332(defun callback-address (callback)
333 #+cmu(alien::callback-trampoline callback)
334 #+(and sbcl (not alien-callbacks))(sb-alien:alien-function-sap callback)
335 #+(and sbcl alien-callbacks)(sb-alien:alien-sap callback))
336
337#+sbcl
338(deftype callback ()
339 #-alien-callbacks'sb-alien:alien-function
340 #+alien-callbacks'sb-alien:alien)
341
342
343;;; The callback code for CLISP is based on code from CFFI
344;;; Copyright (C) 2005, James Bielman <jamesjb@jamesjb.com>
345;;; (C) 2005, Joerg Hoehle <hoehle@users.sourceforge.net>
346
347
348;;; *CALLBACKS* contains the callbacks defined by the %DEFCALLBACK
349;;; macro. The symbol naming the callback is the key, and the value
350;;; is a list containing a Lisp function, the parsed CLISP FFI type of
351;;; the callback, and a saved pointer that should not persist across
352;;; saved images.
353#+clisp
354(progn
355 (defvar *callbacks* (make-hash-table))
356
357 ;;; Return a CLISP FFI function type for a CFFI callback function
358 ;;; given a return type and list of argument names and types.
359 (eval-when (:compile-toplevel :load-toplevel :execute)
360 (defun callback-type (return-type arg-names arg-types)
361 (ffi:parse-c-type
362 `(ffi:c-function
363 (:arguments ,@(mapcar (lambda (sym type)
364 (list sym (alien-type type)))
365 arg-names arg-types))
366 (:return-type ,(alien-type return-type))
367 (:language :stdc)))))
368
369 ;;; Register and create a callback function.
370 (defun register-callback (name function parsed-type)
371 (setf (gethash name *callbacks*)
372 (list function parsed-type
373 (ffi:with-foreign-object (ptr 'ffi:c-pointer)
374 ;; Create callback by converting Lisp function to foreign
375 (setf (ffi:memory-as ptr parsed-type) function)
376 (ffi:foreign-value ptr)))))
377
378 ;;; Restore all saved callback pointers when restarting the Lisp
379 ;;; image. This is pushed onto CUSTOM:*INIT-HOOKS*.
380 ;;; Needs clisp > 2.35, bugfix 2005-09-29
381 (defun restore-callback-pointers ()
382 (maphash
383 (lambda (name list)
384 (register-callback name (first list) (second list)))
385 *callbacks*))
386
387 ;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run
388 ;;; when an image is restarted.
389 (eval-when (:load-toplevel :execute)
390 (pushnew 'restore-callback-pointers custom:*init-hooks*))
391
392 ;;; Define a callback function NAME to run BODY with arguments
393 ;;; ARG-NAMES translated according to ARG-TYPES and the return type
394 ;;; translated according to RETTYPE. Obtain a pointer that can be
395 ;;; passed to C code for this callback by calling %CALLBACK.
396 (defmacro define-callback (name return-type args &body body)
c52ab022 397 (let* ((args (mapcar #'(lambda (arg)
398 (if (atom arg) (list arg arg) arg))
399 args))
400 (arg-names (mapcar #'first args))
401 (arg-types (mapcar #'second args)))
beae6579 402 `(progn
403 (defvar ,name ',name)
404 (register-callback ',name
405 (lambda ,arg-names ,@(callback-body args return-type body))
406 ,(callback-type return-type arg-names arg-types)))))
407
408 ;;; Look up the name of a callback and return a pointer that can be
409 ;;; passed to a C function. Signals an error if no callback is
410 ;;; defined called NAME.
411 (defun callback-address (name)
412 (multiple-value-bind (list winp) (gethash name *callbacks*)
413 (unless winp
414 (error "Undefined callback: ~S" name))
415 (third list)))
416
417 (deftype callback () 'symbol))
418
419
420
421;;;; Type expansion
422
423(defun type-expand-1 (form)
424 #+(or cmu sbcl)
425 (let ((def (cond ((symbolp form)
426 #+cmu(kernel::info type expander form)
427 #+sbcl(sb-impl::info :type :expander form))
428 ((and (consp form) (symbolp (car form)))
429 #+cmu(kernel::info type expander (car form))
430 #+sbcl(sb-impl::info :type :expander (car form)))
431 (t nil))))
432 (if def
433 (values (funcall def (if (consp form) form (list form))) t)
434 (values form nil)))
435 #+clisp(ext:type-expand form t))
436
437(defun type-expand-to (type form)
438 (labels ((expand (form0)
439 (if (eq (first (mklist form0)) type)
440 form0
441 (multiple-value-bind (expanded-form expanded-p)
442 (type-expand-1 form0)
443 (if expanded-p
444 (expand expanded-form)
445 (error "~A can not be expanded to ~A" form type))))))
446 (expand form)))
447
448
449
450;;;; Type methods
451
2c708568 452(defun find-type-method (name type-spec &optional (error-p t))
453 (let ((type-methods (get name 'type-methods))
454 (specifier (if (atom type-spec)
455 type-spec
456 (first type-spec))))
457 (or
458 (gethash specifier type-methods)
459 (when error-p
460 (error
461 "No explicit type method for ~A when call width type specifier ~A found"
462 name type-spec)))))
463
beae6579 464(defun find-next-type-method (name type-spec &optional (error-p t))
465 (let ((type-methods (get name 'type-methods)))
466 (labels ((search-method-in-cpl-order (classes)
467 (when classes
468 (or
469 (gethash (class-name (first classes)) type-methods)
470 (search-method-in-cpl-order (rest classes)))))
471 (lookup-method (type-spec)
472 (if (and (symbolp type-spec) (find-class type-spec nil))
473 (let ((class (find-class type-spec)))
584285fb 474 #?(or (sbcl>= 0 9 15) (featurep :clisp))
beae6579 475 (unless (class-finalized-p class)
476 (finalize-inheritance class))
477 (search-method-in-cpl-order
478 (rest (class-precedence-list class))))
479 (multiple-value-bind (expanded-type expanded-p)
480 (type-expand-1 type-spec)
481 (when expanded-p
482 (or
483 (let ((specifier (etypecase expanded-type
484 (symbol expanded-type)
485 (list (first expanded-type)))))
486 (gethash specifier type-methods))
487 (lookup-method expanded-type))))))
488 (search-built-in-type-hierarchy (sub-tree)
489 (when (subtypep type-spec (first sub-tree))
490 (or
491 (search-nodes (cddr sub-tree))
492 (second sub-tree))))
493 (search-nodes (nodes)
494 (loop
495 for node in nodes
496 as method = (search-built-in-type-hierarchy node)
497 until method
498 finally (return method))))
499 (or
500 (lookup-method type-spec)
501 ;; This is to handle unexpandable types whichs doesn't name a
502 ;; class. It may cause infinite loops with illegal
503 ;; call-next-method calls
b673a77b 504 (unless (or
505 (null type-spec)
506 (and (symbolp type-spec) (find-class type-spec nil)))
beae6579 507 (search-nodes (get name 'built-in-type-hierarchy)))
508 (when error-p
509 (error "No next type method ~A for type specifier ~A"
510 name type-spec))))))
511
512(defun find-applicable-type-method (name type-spec &optional (error-p t))
2c708568 513 (or
514 (find-type-method name type-spec nil)
515 (find-next-type-method name type-spec nil)
516 (when error-p
517 (error
518 "No applicable type method for ~A when call width type specifier ~A"
519 name type-spec))))
520
beae6579 521
522(defun insert-type-in-hierarchy (specifier function nodes)
523 (cond
524 ((let ((node (find specifier nodes :key #'first)))
525 (when node
526 (setf (second node) function)
527 nodes)))
528 ((let ((node
529 (find-if
530 #'(lambda (node)
531 (subtypep specifier (first node)))
532 nodes)))
533 (when node
534 (setf (cddr node)
535 (insert-type-in-hierarchy specifier function (cddr node)))
536 nodes)))
537 ((let ((sub-nodes (remove-if-not
538 #'(lambda (node)
539 (subtypep (first node) specifier))
540 nodes)))
541 (cons
542 (list* specifier function sub-nodes)
543 (nset-difference nodes sub-nodes))))))
544
545(defun add-type-method (name specifier function)
546 (setf (gethash specifier (get name 'type-methods)) function)
547 (when (typep (find-class specifier nil) 'built-in-class)
548 (setf (get name 'built-in-type-hierarchy)
549 (insert-type-in-hierarchy specifier function
550 (get name 'built-in-type-hierarchy)))))
551
552
553(defmacro define-type-generic (name lambda-list &optional documentation)
554 (let ((type-spec (first lambda-list)))
555 (if (or
556 (not lambda-list)
557 (find type-spec '(&optional &key &rest &allow-other-keys)))
558 (error "A type generic needs at least one required argument")
559 `(progn
560 (unless (get ',name 'type-methods)
561 (setf (get ',name 'type-methods) (make-hash-table))
562 (setf (get ',name 'built-in-type-hierarchy) ()))
563 ,(if (intersection '(&optional &key &rest &allow-other-keys) lambda-list)
564 (let ((args (make-symbol "ARGS")))
565 `(defun ,name (,type-spec &rest ,args)
566 ,documentation
567 (apply
568 (find-applicable-type-method ',name ,type-spec)
569 ,type-spec ,args)))
570 `(defun ,name ,lambda-list
571 ,documentation
572 (funcall
573 (find-applicable-type-method ',name ,type-spec)
574 ,@lambda-list)))))))
575
576
577(defmacro define-type-method (name lambda-list &body body)
578 (let ((specifier (cadar lambda-list))
579 (args (make-symbol "ARGS")))
580 `(progn
581 (add-type-method ',name ',specifier
582 #'(lambda (&rest ,args)
583 (flet ((call-next-method (&rest args)
584 (let ((next-method (find-next-type-method ',name ',specifier)))
585 (apply next-method (or args ,args)))))
586 (destructuring-bind (,(caar lambda-list) ,@(rest lambda-list)) ,args
587 ,@body))))
588 ',name)))
589
590
591;;; Rules for auto-exporting symbols
592
593(defexport defbinding (name &rest args)
594 (declare (ignore args))
595 (if (symbolp name)
596 name
597 (first name)))
598
599(defexport define-type-generic (name &rest args)
600 (declare (ignore args))
601 name)