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 (multiple-value-bind (lisp-name c-name)
101 (values name (default-alien-fname name))
104 (let* ((lambda-list-supplied-p lambda-list)
105 (lambda-list (unless (equal lambda-list '(nil)) lambda-list))
108 (doc-string (when (stringp (first args)) (pop args)))
113 (expr type &optional (style :in) (out-type type))
118 ((find style '(:in-out :return))
119 (warn "Deprecated argument style: ~S" style))
120 ((not (find style '(:in :out :in/out :in/return)))
121 (error "Bogus argument style: ~S" style)))
123 (not lambda-list-supplied-p)
124 (namep expr) (in-arg-p style)
125 (not (find expr lambda-list)))
126 (push expr lambda-list)
127 (push type arg-types))
128 (let ((aux (unless (or (not (in-arg-p style)) (namep expr))
131 (push (list aux expr) aux-bindings))
134 ((and (namep expr) (not (in-arg-p style))) expr)
136 #-clisp(make-symbol (string expr))
137 ;; The above used to work in CLISP, but I'm
138 ;; not sure exactly at which version it
139 ;; broke. The following could potentially
140 ;; cause variable capturing
141 #+clisp(intern (format nil "~A-~A" (string expr) (gensym))))
143 #+clisp(intern (string (gensym)))))
144 (or aux expr) type style out-type))))
147 (%defbinding c-name lisp-name
148 (if lambda-list-supplied-p lambda-list (nreverse lambda-list))
149 (not lambda-list-supplied-p) (nreverse arg-types)
150 aux-bindings return-type doc-string parsed-args))))
154 (defun foreign-funcall (cname args return-type)
156 for (var expr type style out-type) in args
157 collect (if (out-arg-p style)
161 for (var expr type style out-type) in args
162 collect (if (out-arg-p style)
163 `(* ,(alien-type out-type))
164 (alien-type out-type))))
165 (fname (make-symbol cname)))
166 `(with-alien ((,fname (function ,(alien-type return-type) ,@ftypes) :extern ,cname))
167 (alien-funcall ,fname ,@fparams))))
170 (defun foreign-funcall (cname args return-type)
171 (let* ((fparams (loop
172 for (var expr type style out-type) in args
173 collect (if (out-arg-p style)
174 `(ffi:c-var-address ,var)
177 for (var expr type style out-type) in args
178 collect (list var (if (out-arg-p style)
180 (alien-type out-type)))))
181 (c-function `(ffi:c-function
183 (:return-type ,(alien-type return-type))
187 (ffi::foreign-library-function
188 ,cname (ffi::foreign-library :default) #?(clisp>= 2 40)nil
189 nil (ffi:parse-c-type ',c-function)))
193 ;; TODO: check if in and out types (if different) translates to same
195 (defun %defbinding (cname lisp-name lambda-list declare-p arg-types aux-bindings return-type doc args)
197 for (var expr type style out-type) in args
198 when (or (out-arg-p style) (return-arg-p style))
199 collect (from-alien-form out-type var)))
200 (fcall (from-alien-form return-type
201 (foreign-funcall cname args return-type))))
203 (labels ((create-wrapper (args body)
205 (destructuring-bind (var expr type style out-type) (first args)
206 (declare (ignore out-type))
207 (alien-arg-wrapper type var expr style
208 (create-wrapper (rest args) body)))
215 ,(mapcar #'argument-type arg-types)
217 ,@(when return-type (list (return-type return-type)))
219 for (var expr type style out-type) in args
220 when (out-arg-p style)
221 collect (return-type out-type)
222 when (return-arg-p style)
223 collect (return-type type))))
225 (defun ,lisp-name ,lambda-list
229 (create-wrapper args `(values ,fcall ,@out))
230 (create-wrapper args `(progn ,fcall (values ,@out))))))))))
234 ;;;; Dynamic (runtime) bindings
236 (defun mkbinding (name return-type &rest arg-types)
237 #+cmu(declare (optimize (inhibit-warnings 3)))
238 #+sbcl(declare (muffle-conditions compiler-note))
241 `(function ,@(mapcar #'alien-type (cons return-type arg-types)))
244 (:arguments ,@(mapcar
246 (list (gensym) (alien-type type)))
248 (:return-type ,(alien-type return-type))
252 (handler-bind (#+sbcl(compiler-note #'(lambda (condition)
253 (declare (ignore condition))
256 (make-heap-alien-info
257 :type (parse-alien-type c-function #+sbcl nil)
258 :sap-form (let ((address (foreign-symbol-address name)))
260 (integer (int-sap address))
261 (system-area-pointer address))))))
263 (ffi::foreign-library-function name
264 (ffi::foreign-library :default) #?(clisp>= 2 40)nil
265 nil (ffi:parse-c-type c-function)))
266 (return-value-translator (from-alien-function return-type)))
267 (multiple-value-bind (arg-translators cleanup-funcs)
268 (let ((translator/cleanup-pairs
271 (multiple-value-list (to-alien-function type)))
274 (mapcar #'first translator/cleanup-pairs)
275 (mapcar #'second translator/cleanup-pairs)))
276 #'(lambda (&rest args)
277 (let ((translated-args (mapcar #'funcall arg-translators args)))
279 (funcall return-value-translator
280 #+(or cmu sbcl)(apply #'alien-funcall foreign translated-args)
281 #+clisp(apply foreign translated-args))
283 #'(lambda (cleanup arg translated-arg)
285 (funcall cleanup arg translated-arg)))
286 cleanup-funcs args translated-args)))))))
292 (defun callback-body (args return-type body)
293 (labels ((create-wrappers (args body)
295 (destructuring-bind (var type) (first args)
296 (callback-wrapper type var var
297 (create-wrappers (rest args) body)))
299 (create-body (args body)
300 (to-alien-form return-type
301 (create-wrappers args `(progn ,@body)))))
302 (if (and (consp (first body)) (eq (caar body) 'declare))
304 for declaration in (cdar body)
305 when (eq (first declaration) 'ignore)
306 nconc (rest declaration))))
309 (remove-if #'(lambda (arg)
310 (find (first arg) ignored))
313 (list (create-body args body)))))
317 (defmacro define-callback (name return-type args &body body)
318 (let ((define-callback
319 #+cmu'alien:def-callback
320 #+(and sbcl alien-callbacks)'sb-alien::define-alien-callback
321 #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function)
322 (args (mapcar #'(lambda (arg)
323 (if (atom arg) (list arg arg) arg))
326 #+cmu(defparameter ,name nil)
327 (,define-callback ,name
328 #+(and sbcl alien-callbacks) ,(alien-type return-type)
329 (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type)
331 for (name type) in args
332 collect `(,name ,(alien-type type))))
333 ,@(callback-body args return-type body)))))
336 (defun callback-address (callback)
337 #+cmu(alien::callback-trampoline callback)
338 #+(and sbcl (not alien-callbacks))(sb-alien:alien-function-sap callback)
339 #+(and sbcl alien-callbacks)(sb-alien:alien-sap callback))
343 #-alien-callbacks'sb-alien:alien-function
344 #+alien-callbacks'sb-alien:alien)
347 ;;; The callback code for CLISP is based on code from CFFI
348 ;;; Copyright (C) 2005, James Bielman <jamesjb@jamesjb.com>
349 ;;; (C) 2005, Joerg Hoehle <hoehle@users.sourceforge.net>
352 ;;; *CALLBACKS* contains the callbacks defined by the %DEFCALLBACK
353 ;;; macro. The symbol naming the callback is the key, and the value
354 ;;; is a list containing a Lisp function, the parsed CLISP FFI type of
355 ;;; the callback, and a saved pointer that should not persist across
359 (defvar *callbacks* (make-hash-table))
361 ;;; Return a CLISP FFI function type for a CFFI callback function
362 ;;; given a return type and list of argument names and types.
363 (eval-when (:compile-toplevel :load-toplevel :execute)
364 (defun callback-type (return-type arg-names arg-types)
367 (:arguments ,@(mapcar (lambda (sym type)
368 (list sym (alien-type type)))
369 arg-names arg-types))
370 (:return-type ,(alien-type return-type))
371 (:language :stdc)))))
373 ;;; Register and create a callback function.
374 (defun register-callback (name function parsed-type)
375 (setf (gethash name *callbacks*)
376 (list function parsed-type
377 (ffi:with-foreign-object (ptr 'ffi:c-pointer)
378 ;; Create callback by converting Lisp function to foreign
379 (setf (ffi:memory-as ptr parsed-type) function)
380 (ffi:foreign-value ptr)))))
382 ;;; Restore all saved callback pointers when restarting the Lisp
383 ;;; image. This is pushed onto CUSTOM:*INIT-HOOKS*.
384 ;;; Needs clisp > 2.35, bugfix 2005-09-29
385 (defun restore-callback-pointers ()
388 (register-callback name (first list) (second list)))
391 ;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run
392 ;;; when an image is restarted.
393 (eval-when (:load-toplevel :execute)
394 (pushnew 'restore-callback-pointers custom:*init-hooks*))
396 ;;; Define a callback function NAME to run BODY with arguments
397 ;;; ARG-NAMES translated according to ARG-TYPES and the return type
398 ;;; translated according to RETTYPE. Obtain a pointer that can be
399 ;;; passed to C code for this callback by calling %CALLBACK.
400 (defmacro define-callback (name return-type args &body body)
401 (let* ((args (mapcar #'(lambda (arg)
402 (if (atom arg) (list arg arg) arg))
404 (arg-names (mapcar #'first args))
405 (arg-types (mapcar #'second args)))
407 (defvar ,name ',name)
408 (register-callback ',name
409 (lambda ,arg-names ,@(callback-body args return-type body))
410 ,(callback-type return-type arg-names arg-types)))))
412 ;;; Look up the name of a callback and return a pointer that can be
413 ;;; passed to a C function. Signals an error if no callback is
414 ;;; defined called NAME.
415 (defun callback-address (name)
416 (multiple-value-bind (list winp) (gethash name *callbacks*)
418 (error "Undefined callback: ~S" name))
421 (deftype callback () 'symbol))
427 (defun type-expand-1 (form)
429 (let ((def (cond ((symbolp form)
430 #+cmu(kernel::info type expander form)
431 #+sbcl(sb-impl::info :type :expander form))
432 ((and (consp form) (symbolp (car form)))
433 #+cmu(kernel::info type expander (car form))
434 #+sbcl(sb-impl::info :type :expander (car form)))
437 (values (funcall def (if (consp form) form (list form))) t)
439 #+clisp(ext:type-expand form t))
441 (defun type-expand-to (type form)
442 (labels ((expand (form0)
443 (if (eq (first (mklist form0)) type)
445 (multiple-value-bind (expanded-form expanded-p)
446 (type-expand-1 form0)
448 (expand expanded-form)
449 (error "~A can not be expanded to ~A" form type))))))
452 (defun type-equal-p (type1 type2)
453 (and (subtypep type1 type2) (subtypep type2 type1)))
458 (defun find-type-method (name type-spec &optional (error-p t))
459 (let ((type-methods (get name 'type-methods))
460 (specifier (if (atom type-spec)
464 (gethash specifier type-methods)
467 "No explicit type method for ~A when call width type specifier ~A found"
470 (defun find-next-type-method (name type-spec &optional (error-p t))
471 (let ((type-methods (get name 'type-methods)))
472 (labels ((search-method-in-cpl-order (classes)
475 (gethash (class-name (first classes)) type-methods)
476 (search-method-in-cpl-order (rest classes)))))
477 (lookup-method (type-spec)
478 (if (and (symbolp type-spec) (find-class type-spec nil))
479 (let ((class (find-class type-spec)))
480 #?(or (sbcl>= 0 9 15) (featurep :clisp))
481 (unless (class-finalized-p class)
482 (finalize-inheritance class))
483 (search-method-in-cpl-order
484 (rest (class-precedence-list class))))
485 (multiple-value-bind (expanded-type expanded-p)
486 (type-expand-1 type-spec)
489 (let ((specifier (etypecase expanded-type
490 (symbol expanded-type)
491 (list (first expanded-type)))))
492 (gethash specifier type-methods))
493 (lookup-method expanded-type))))))
494 (search-built-in-type-hierarchy (sub-tree)
495 (when (subtypep type-spec (first sub-tree))
497 (search-nodes (cddr sub-tree))
499 (search-nodes (nodes)
502 as method = (search-built-in-type-hierarchy node)
504 finally (return method))))
506 (lookup-method type-spec)
507 ;; This is to handle unexpandable types whichs doesn't name a
508 ;; class. It may cause infinite loops with illegal
509 ;; call-next-method calls
512 (and (symbolp type-spec) (find-class type-spec nil)))
513 (search-nodes (get name 'built-in-type-hierarchy)))
515 (error "No next type method ~A for type specifier ~A"
518 (defun find-applicable-type-method (name type-spec &optional (error-p t))
520 (find-type-method name type-spec nil)
521 (find-next-type-method name type-spec nil)
524 "No applicable type method for ~A when call width type specifier ~A"
528 (defun insert-type-in-hierarchy (specifier function nodes)
530 ((let ((node (find specifier nodes :key #'first)))
532 (setf (second node) function)
537 (subtypep specifier (first node)))
541 (insert-type-in-hierarchy specifier function (cddr node)))
543 ((let ((sub-nodes (remove-if-not
545 (subtypep (first node) specifier))
548 (list* specifier function sub-nodes)
549 (nset-difference nodes sub-nodes))))))
551 (defun add-type-method (name specifier function)
552 (setf (gethash specifier (get name 'type-methods)) function)
553 (when (typep (find-class specifier nil) 'built-in-class)
554 (setf (get name 'built-in-type-hierarchy)
555 (insert-type-in-hierarchy specifier function
556 (get name 'built-in-type-hierarchy)))))
559 (defmacro define-type-generic (name lambda-list &optional documentation)
560 (let ((type-spec (first lambda-list)))
563 (find type-spec '(&optional &key &rest &allow-other-keys)))
564 (error "A type generic needs at least one required argument")
566 (unless (get ',name 'type-methods)
567 (setf (get ',name 'type-methods) (make-hash-table))
568 (setf (get ',name 'built-in-type-hierarchy) ()))
569 ,(if (intersection '(&optional &key &rest &allow-other-keys) lambda-list)
570 (let ((args (make-symbol "ARGS")))
571 `(defun ,name (,type-spec &rest ,args)
574 (find-applicable-type-method ',name ,type-spec)
576 `(defun ,name ,lambda-list
579 (find-applicable-type-method ',name ,type-spec)
583 (defmacro define-type-method (name lambda-list &body body)
584 (let ((specifier (cadar lambda-list))
585 (args (make-symbol "ARGS")))
587 (add-type-method ',name ',specifier
588 #'(lambda (&rest ,args)
589 (flet ((call-next-method (&rest args)
590 (let ((next-method (find-next-type-method ',name ',specifier)))
591 (apply next-method (or args ,args)))))
592 (destructuring-bind (,(caar lambda-list) ,@(rest lambda-list)) ,args
597 ;;; Rules for auto-exporting symbols
599 (defexport defbinding (name &rest args)
600 (declare (ignore args))
605 (defexport define-type-generic (name &rest args)
606 (declare (ignore args))