1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 1999-2006 Espen S. Johnsen <espen@users.sf.net>
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:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
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.
23 ;; $Id: interface.lisp,v 1.10 2008-12-10 02:40:18 espen Exp $
28 ;;;; Foreign function call interface
30 (defvar *package-prefix* nil)
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*))
38 (defun package-prefix (&optional (package *package*))
39 (let ((package (find-package package)))
41 (cdr (assoc package *package-prefix*))
42 (substitute #\_ #\- (string-downcase (package-name package))))))
44 (defun find-prefix-package (prefix)
46 (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=))
47 (find-package (string-upcase prefix))))
49 (defmacro use-prefix (prefix &optional (package *package*))
50 `(eval-when (:compile-toplevel :load-toplevel :execute)
51 (set-package-prefix ,prefix ,package)))
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))
60 (stripped-name (subseq name start end))
61 (prefix (package-prefix *package*)))
62 (if (or (not prefix) (string= prefix ""))
64 (format nil "~A_~A" prefix stripped-name))))
66 (defun default-alien-type-name (type-name)
67 (let ((prefix (package-prefix *package*)))
73 (cons prefix (split-string (symbol-name type-name) :delimiter #\-))))))
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)))
80 (error "Couldn't split alien name '~A' to find a registered prefix"
82 (when (find-prefix-package prefix)
83 (return (values (string-upcase (concatenate-strings rest #\-))
84 (find-prefix-package prefix)))))))
86 (defun default-type-name (alien-name)
87 (multiple-value-call #'intern (split-alien-name alien-name)))
89 (defun in-arg-p (style)
90 (find style '(:in :in/out :in/return :in-out :return)))
92 (defun out-arg-p (style)
93 (find style '(:out :in/out :in-out)))
95 (defun return-arg-p (style)
96 (find style '(:in/return :return)))
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.
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.
109 RETURN-TYPE should be a valid type.
111 A normal element of ARGS is a list matching
113 (EXPR TYPE &OPTIONAL (STYLE :IN) (OUT-TYPE TYPE))
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.
121 To give the binding a docstring, pass a string as the first element of ARGS."
122 (multiple-value-bind (lisp-name c-name)
124 (values name (default-alien-fname name))
127 (let* ((lambda-list-supplied-p lambda-list)
128 (lambda-list (unless (equal lambda-list '(nil)) lambda-list))
131 (doc-string (when (stringp (first args)) (pop args)))
136 (expr type &optional (style :in) (out-type type))
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)))
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))
154 (push (list aux expr) aux-bindings))
157 ((and (namep expr) (not (in-arg-p style))) 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))))
166 #+clisp(intern (string (gensym)))))
167 (or aux expr) type style out-type))))
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))))
177 (defun foreign-funcall (cname args return-type)
179 for (var expr type style out-type) in args
180 collect (if (out-arg-p style)
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))))
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)
200 for (var expr type style out-type) in args
201 collect (list var (if (out-arg-p style)
203 (alien-type out-type)))))
204 (c-function `(ffi:c-function
206 (:return-type ,(alien-type return-type))
210 (ffi::foreign-library-function
211 ,cname (ffi::foreign-library :default) #?(clisp>= 2 40)nil
212 nil (ffi:parse-c-type ',c-function)))
216 ;; TODO: check if in and out types (if different) translates to same
218 (defun %defbinding (cname lisp-name lambda-list declare-p arg-types aux-bindings return-type doc args)
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))))
226 (labels ((create-wrapper (args body)
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)))
238 ,(mapcar #'argument-type arg-types)
240 ,@(when return-type (list (return-type return-type)))
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))))
248 (defun ,lisp-name ,lambda-list
252 (create-wrapper args `(values ,fcall ,@out))
253 (create-wrapper args `(progn ,fcall (values ,@out))))))))))
257 ;;;; Dynamic (runtime) bindings
259 (defun mkbinding (name return-type &rest arg-types)
260 #+cmu(declare (optimize (inhibit-warnings 3)))
261 #+sbcl(declare (muffle-conditions compiler-note))
264 `(function ,@(mapcar #'alien-type (cons return-type arg-types)))
267 (:arguments ,@(mapcar
269 (list (gensym) (alien-type type)))
271 (:return-type ,(alien-type return-type))
275 (handler-bind (#+sbcl(compiler-note #'(lambda (condition)
276 (declare (ignore condition))
279 (make-heap-alien-info
280 :type (parse-alien-type c-function #+sbcl nil)
281 :sap-form (let ((address (foreign-symbol-address name)))
283 (integer (int-sap address))
284 (system-area-pointer address))))))
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
294 (multiple-value-list (to-alien-function type)))
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)))
302 (funcall return-value-translator
303 #+(or cmu sbcl)(apply #'alien-funcall foreign translated-args)
304 #+clisp(apply foreign translated-args))
306 #'(lambda (cleanup arg translated-arg)
308 (funcall cleanup arg translated-arg)))
309 cleanup-funcs args translated-args)))))))
315 (defun callback-body (args return-type body)
316 (labels ((create-wrappers (args body)
318 (destructuring-bind (var type) (first args)
319 (callback-wrapper type var var
320 (create-wrappers (rest args) 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))
327 for declaration in (cdar body)
328 when (eq (first declaration) 'ignore)
329 nconc (rest declaration))))
332 (remove-if #'(lambda (arg)
333 (find (first arg) ignored))
336 (list (create-body args body)))))
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))
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)
354 for (name type) in args
355 collect `(,name ,(alien-type type))))
356 ,@(callback-body args return-type body)))))
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))
366 #-alien-callbacks'sb-alien:alien-function
367 #+alien-callbacks'sb-alien:alien)
370 ;;; The callback code for CLISP is based on code from CFFI
371 ;;; Copyright (C) 2005, James Bielman <jamesjb@jamesjb.com>
372 ;;; (C) 2005, Joerg Hoehle <hoehle@users.sourceforge.net>
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
382 (defvar *callbacks* (make-hash-table))
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)
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)))))
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)))))
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 ()
411 (register-callback name (first list) (second list)))
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*))
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))
427 (arg-names (mapcar #'first args))
428 (arg-types (mapcar #'second args)))
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)))))
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*)
441 (error "Undefined callback: ~S" name))
444 (deftype callback () 'symbol))
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))))
456 (defun type-expand-1 (form)
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)))
466 (values (funcall def (if (consp form) form (list form))) t)
468 #+clisp(ext:type-expand form t))
470 (defun type-expand-to (type form)
471 (labels ((expand (form0)
472 (if (eq (first (mklist form0)) type)
474 (multiple-value-bind (expanded-form expanded-p)
475 (type-expand-1 form0)
477 (expand expanded-form)
478 (error "~A can not be expanded to ~A" form type))))))
481 (defun type-equal-p (type1 type2)
482 (and (subtypep type1 type2) (subtypep type2 type1)))
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)
493 (gethash specifier type-methods)
496 "No explicit type method for ~A when call width type specifier ~A found"
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)
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)
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))
526 (search-nodes (cddr sub-tree))
528 (search-nodes (nodes)
531 as method = (search-built-in-type-hierarchy node)
533 finally (return method))))
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
541 (and (symbolp type-spec) (find-class type-spec nil)))
542 (search-nodes (get name 'built-in-type-hierarchy)))
544 (error "No next type method ~A for type specifier ~A"
547 (defun find-applicable-type-method (name type-spec &optional (error-p t))
549 (find-type-method name type-spec nil)
550 (find-next-type-method name type-spec nil)
553 "No applicable type method for ~A when call width type specifier ~A"
557 (defun insert-type-in-hierarchy (specifier function nodes)
559 ((let ((node (find specifier nodes :key #'first)))
561 (setf (second node) function)
566 (subtypep specifier (first node)))
570 (insert-type-in-hierarchy specifier function (cddr node)))
572 ((let ((sub-nodes (remove-if-not
574 (subtypep (first node) specifier))
577 (list* specifier function sub-nodes)
578 (nset-difference nodes sub-nodes))))))
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)))))
588 (defmacro define-type-generic (name lambda-list &optional documentation)
589 (let ((type-spec (first lambda-list)))
592 (find type-spec '(&optional &key &rest &allow-other-keys)))
593 (error "A type generic needs at least one required argument")
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)
603 (find-applicable-type-method ',name ,type-spec)
605 `(defun ,name ,lambda-list
608 (find-applicable-type-method ',name ,type-spec)
612 (defmacro define-type-method (name lambda-list &body body)
613 (let ((specifier (cadar lambda-list))
614 (args (make-symbol "ARGS")))
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
626 ;;; Rules for auto-exporting symbols
628 (defexport defbinding (name &rest args)
629 (declare (ignore args))
634 (defexport define-type-generic (name &rest args)
635 (declare (ignore args))