X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/8755b1a5d37f2f4b853c01f0d8b121ab9ee4093a..6896c0f3344ff5cdf23bdd634a9413c782bdcbd7:/glib/ffi.lisp diff --git a/glib/ffi.lisp b/glib/ffi.lisp index 46f69de..56fe1da 100644 --- a/glib/ffi.lisp +++ b/glib/ffi.lisp @@ -1,5 +1,5 @@ ;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 1999-2001 Espen S. Johnsen +;; Copyright (C) 1999-2005 Espen S. Johnsen ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -15,7 +15,7 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;; $Id: ffi.lisp,v 1.3 2004-11-07 01:23:38 espen Exp $ +;; $Id: ffi.lisp,v 1.19 2005-04-17 21:49:19 espen Exp $ (in-package "GLIB") @@ -47,15 +47,22 @@ (defun default-alien-fname (lisp-name) - (let* ((lisp-name-string - (if (char= (char (the simple-string (string lisp-name)) 0) #\%) - (subseq (the simple-string (string lisp-name)) 1) - (string lisp-name))) - (prefix (package-prefix *package*)) - (name (substitute #\_ #\- (string-downcase lisp-name-string)))) + (let* ((name (substitute #\_ #\- (string-downcase lisp-name))) + (stripped-name + (cond + ((and + (char= (char name 0) #\%) + (string= "_p" name :start2 (- (length name) 2))) + (subseq name 1 (- (length name) 2))) + ((char= (char name 0) #\%) + (subseq name 1)) + ((string= "_p" name :start2 (- (length name) 2)) + (subseq name 0 (- (length name) 2))) + (name))) + (prefix (package-prefix *package*))) (if (or (not prefix) (string= prefix "")) - name - (format nil "~A_~A" prefix name)))) + stripped-name + (format nil "~A_~A" prefix stripped-name)))) (defun default-alien-type-name (type-name) (let ((prefix (package-prefix *package*))) @@ -90,55 +97,64 @@ (push doc/arg docs) (progn (destructuring-bind (expr type &optional (style :in)) doc/arg - (unless (member style '(:in :out :in-out)) + (unless (member style '(:in :out :in-out :return)) (error "Bogus argument style ~S in ~S." style doc/arg)) (when (and (not supplied-lambda-list) - (namep expr) (member style '(:in :in-out))) + (namep expr) (member style '(:in :in-out :return))) (push expr lambda-list)) - (push - (list (if (namep expr) - (make-symbol (string expr)) - (gensym)) - expr (mklist type) style) args))))) + (push (list (cond + ((and (namep expr) (eq style :out)) expr) + ((namep expr) (make-symbol (string expr))) + ((gensym))) + expr (mklist type) style) args))))) (%defbinding c-name lisp-name (or supplied-lambda-list (nreverse lambda-list)) return-type (reverse docs) (reverse args))))) -#+cmu +#+(or cmu sbcl) (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args) - (ext:collect ((alien-types) (alien-bindings) (alien-parameters) - (alien-values) (cleanup-forms)) + (collect ((alien-types) (alien-bindings) (alien-parameters) + (return-values) (cleanup-forms)) (dolist (arg args) (destructuring-bind (var expr type style) arg (let ((declaration (alien-type type)) (cleanup (cleanup-form var type))) (cond - ((member style '(:out :in-out)) - (alien-types `(* ,declaration)) - (alien-parameters `(addr ,var)) - (alien-bindings - `(,var ,declaration - ,@(when (eq style :in-out) - (list (to-alien-form expr type))))) - (alien-values (from-alien-form var type))) - (cleanup - (alien-types declaration) - (alien-bindings - `(,var ,declaration ,(to-alien-form expr type))) - (alien-parameters var) - (cleanup-forms cleanup)) - (t - (alien-types declaration) - (alien-parameters (to-alien-form expr type))))))) + ((member style '(:out :in-out)) + (alien-types `(* ,declaration)) + (alien-parameters `(addr ,var)) + (alien-bindings + `(,var ,declaration + ,@(cond + ((eq style :in-out) (list (to-alien-form expr type))) + ((eq declaration 'system-area-pointer) + (list '(make-pointer 0)))))) + (return-values (from-alien-form var type))) + ((eq style :return) + (alien-types declaration) + (alien-bindings + `(,var ,declaration ,(to-alien-form expr type))) + (alien-parameters var) + (return-values (from-alien-form var type))) + (cleanup + (alien-types declaration) + (alien-bindings + `(,var ,declaration ,(to-alien-form expr type))) + (alien-parameters var) + (cleanup-forms cleanup)) + (t + (alien-types declaration) + (alien-parameters (to-alien-form expr type))))))) (let* ((alien-name (make-symbol (string lisp-name))) (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters)))) `(defun ,lisp-name ,lambda-list ,@docs - (declare (optimize (ext:inhibit-warnings 3))) + #+cmu(declare (optimize (inhibit-warnings 3))) + #+sbcl(declare (muffle-conditions compiler-note)) (with-alien ((,alien-name (function ,(alien-type return-type) @@ -150,24 +166,25 @@ (unwind-protect ,(from-alien-form alien-funcall return-type) ,@(cleanup-forms)) - ,@(alien-values)) + ,@(return-values)) `(progn (unwind-protect ,alien-funcall ,@(cleanup-forms)) - (values ,@(alien-values))))))))) + (values ,@(return-values))))))))) ;;; Creates bindings at runtime (defun mkbinding (name return-type &rest arg-types) - (declare (optimize (ext:inhibit-warnings 3))) + #+cmu(declare (optimize (inhibit-warnings 3))) + #+sbcl(declare (muffle-conditions compiler-note)) (let* ((ftype `(function ,@(mapcar #'alien-type (cons return-type arg-types)))) (alien - (alien::%heap-alien - (alien::make-heap-alien-info - :type (alien::parse-alien-type ftype) - :sap-form (system:foreign-symbol-address name :flavor :code)))) + (%heap-alien + (make-heap-alien-info + :type (parse-alien-type ftype #+sbcl nil) + :sap-form (foreign-symbol-address name)))) (translate-arguments (mapcar #'to-alien-function arg-types)) (translate-return-value (from-alien-function return-type)) (cleanup-arguments (mapcar #'cleanup-function arg-types))) @@ -176,26 +193,37 @@ (map-into args #'funcall translate-arguments args) (prog1 (funcall translate-return-value - (apply #'alien:alien-funcall alien args)) + (apply #'alien-funcall alien args)) (mapc #'funcall cleanup-arguments args))))) (defmacro defcallback (name (return-type &rest args) &body body) - `(def-callback ,name - (,(alien-type return-type) - ,@(mapcar #'(lambda (arg) - (destructuring-bind (name type) arg - `(,name ,(alien-type type)))) - args)) - ,(to-alien-form - `(let (,@(mapcar #'(lambda (arg) - (destructuring-bind (name type) arg - `(,name ,(from-alien-form name type)))) - args)) - ,@body) - return-type))) - - + (let ((def-callback #+cmu'alien:def-callback + #+sbcl'sb-alien:define-alien-function)) + `(,def-callback ,name + (,(alien-type return-type) + ,@(mapcar #'(lambda (arg) + (destructuring-bind (name type) arg + `(,name ,(alien-type type)))) + args)) + ,(to-alien-form + `(let (,@(delete nil + (mapcar #'(lambda (arg) + (destructuring-bind (name type) arg + (let ((from-alien + (from-alien-form name type))) + (unless (eq name from-alien) + `(,name ,from-alien))))) + args))) + ,@body) + return-type)))) + +#+sbcl +(defun callback (af) + (sb-alien:alien-function-sap af)) + +#+sbcl +(deftype callback () 'sb-alien:alien-function) ;;;; Definitons and translations of fundamental types @@ -228,10 +256,18 @@ (def-type-method from-alien-function ()) (def-type-method cleanup-function ()) +(def-type-method copy-to-alien-form (form)) +(def-type-method copy-to-alien-function ()) +(def-type-method copy-from-alien-form (form)) +(def-type-method copy-from-alien-function ()) + (def-type-method writer-function ()) (def-type-method reader-function ()) (def-type-method destroy-function ()) +(def-type-method unbound-value () + "First return value is true if the type has an unbound value, second return value is the actual unbound value") + ;; Sizes of fundamental C types in bytes (8 bits) (defconstant +size-of-short+ 2) @@ -288,18 +324,30 @@ (defmethod destroy-function ((type t) &rest args) (declare (ignore type args)) - #'(lambda (location offset) + #'(lambda (location &optional offset) (declare (ignore location offset)))) +(defmethod copy-to-alien-form (form (type t) &rest args) + (apply #'to-alien-form form type args)) + +(defmethod copy-to-alien-function ((type t) &rest args) + (apply #'to-alien-function type args)) + +(defmethod copy-from-alien-form (form (type t) &rest args) + (apply #'from-alien-form form type args)) + +(defmethod copy-from-alien-function ((type t) &rest args) + (apply #'from-alien-function type args)) + (defmethod alien-type ((type (eql 'signed-byte)) &rest args) (declare (ignore type)) (destructuring-bind (&optional (size '*)) args (ecase size - (#.+bits-of-byte+ '(signed-byte 8)) - (#.+bits-of-short+ 'c-call:short) - ((* #.+bits-of-int+) 'c-call:int) - (#.+bits-of-long+ 'c-call:long)))) + (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8)) + (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short) + ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int) + (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long)))) (defmethod size-of ((type (eql 'signed-byte)) &rest args) (declare (ignore type)) @@ -310,6 +358,10 @@ ((* #.+bits-of-int+) +size-of-int+) (#.+bits-of-long+ +size-of-long+)))) +(defmethod unbound-value ((type t) &rest args) + (declare (ignore type args)) + nil) + (defmethod writer-function ((type (eql 'signed-byte)) &rest args) (declare (ignore type)) (destructuring-bind (&optional (size '*)) args @@ -341,10 +393,13 @@ (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args) (destructuring-bind (&optional (size '*)) args (ecase size - (#.+bits-of-byte+ '(unsigned-byte 8)) - (#.+bits-of-short+ 'c-call:unsigned-short) - ((* #.+bits-of-int+) 'c-call:unsigned-int) - (#.+bits-of-long+ 'c-call:unsigned-long)))) + (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8)) + (#.+bits-of-short+ #+cmu 'c-call:unsigned-short + #+sbcl 'sb-alien:unsigned-short) + ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int + #+sbcl 'sb-alien:unsigned-int) + (#.+bits-of-long+ #+cmu 'c-call:unsigned-long + #+sbcl 'sb-alien:unsigned-long)))) (defmethod size-of ((type (eql 'unsigned-byte)) &rest args) (apply #'size-of 'signed args)) @@ -386,6 +441,14 @@ (declare (ignore type args)) (size-of 'signed-byte)) +(defmethod writer-function ((type (eql 'integer)) &rest args) + (declare (ignore type args)) + (writer-function 'signed-byte)) + +(defmethod reader-function ((type (eql 'integer)) &rest args) + (declare (ignore type args)) + (reader-function 'signed-byte)) + (defmethod alien-type ((type (eql 'fixnum)) &rest args) (declare (ignore type args)) @@ -398,12 +461,21 @@ (defmethod alien-type ((type (eql 'single-float)) &rest args) (declare (ignore type args)) - 'alien:single-float) + #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float) (defmethod size-of ((type (eql 'single-float)) &rest args) (declare (ignore type args)) +size-of-float+) +(defmethod to-alien-form (form (type (eql 'single-float)) &rest args) + (declare (ignore type args)) + `(coerce ,form 'single-float)) + +(defmethod to-alien-function ((type (eql 'single-float)) &rest args) + (declare (ignore type args)) + #'(lambda (number) + (coerce number 'single-float))) + (defmethod writer-function ((type (eql 'single-float)) &rest args) (declare (ignore type args)) #'(lambda (value location &optional (offset 0)) @@ -417,11 +489,20 @@ (defmethod alien-type ((type (eql 'double-float)) &rest args) (declare (ignore type args)) - 'alien:double-float) + #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float) (defmethod size-of ((type (eql 'double-float)) &rest args) (declare (ignore type args)) - +size-of-float+) + +size-of-double+) + +(defmethod to-alien-form (form (type (eql 'double-float)) &rest args) + (declare (ignore type args)) + `(coerce ,form 'double-float)) + +(defmethod to-alien-function ((type (eql 'double-float)) &rest args) + (declare (ignore type args)) + #'(lambda (number) + (coerce number 'double-float))) (defmethod writer-function ((type (eql 'double-float)) &rest args) (declare (ignore type args)) @@ -436,7 +517,7 @@ (defmethod alien-type ((type (eql 'base-char)) &rest args) (declare (ignore type args)) - 'c-call:char) + #+cmu 'c-call:char #+sbcl 'sb-alien:char) (defmethod size-of ((type (eql 'base-char)) &rest args) (declare (ignore type args)) @@ -465,28 +546,42 @@ (declare (ignore type args)) `(let ((string ,string)) ;; Always copy strings to prevent seg fault due to GC + #+cmu (copy-memory - (make-pointer (1+ (kernel:get-lisp-obj-address string))) - (1+ (length string))))) + (vector-sap (coerce string 'simple-base-string)) + (1+ (length string))) + #+sbcl + (let ((utf8 (%deport-utf8-string string))) + (copy-memory (vector-sap utf8) (length utf8))))) (defmethod to-alien-function ((type (eql 'string)) &rest args) (declare (ignore type args)) #'(lambda (string) + #+cmu (copy-memory - (make-pointer (1+ (kernel:get-lisp-obj-address string))) - (1+ (length string))))) + (vector-sap (coerce string 'simple-base-string)) + (1+ (length string))) + #+sbcl + (let ((utf8 (%deport-utf8-string string))) + (copy-memory (vector-sap utf8) (length utf8))))) (defmethod from-alien-form (string (type (eql 'string)) &rest args) (declare (ignore type args)) `(let ((string ,string)) (unless (null-pointer-p string) - (c-call::%naturalize-c-string string)))) + (prog1 + #+cmu(%naturalize-c-string string) + #+sbcl(%naturalize-utf8-string string) + (deallocate-memory string))))) (defmethod from-alien-function ((type (eql 'string)) &rest args) (declare (ignore type args)) #'(lambda (string) (unless (null-pointer-p string) - (c-call::%naturalize-c-string string)))) + (prog1 + #+cmu(%naturalize-c-string string) + #+sbcl(%naturalize-utf8-string string) + (deallocate-memory string))))) (defmethod cleanup-form (string (type (eql 'string)) &rest args) (declare (ignore type args)) @@ -500,20 +595,39 @@ (unless (null-pointer-p string) (deallocate-memory string)))) +(defmethod copy-from-alien-form (string (type (eql 'string)) &rest args) + (declare (ignore type args)) + `(let ((string ,string)) + (unless (null-pointer-p string) + #+cmu(%naturalize-c-string string) + #+sbcl(%naturalize-utf8-string string)))) + +(defmethod copy-from-alien-function ((type (eql 'string)) &rest args) + (declare (ignore type args)) + #'(lambda (string) + (unless (null-pointer-p string) + #+cmu(%naturalize-c-string string) + #+sbcl(%naturalize-utf8-string string)))) + (defmethod writer-function ((type (eql 'string)) &rest args) (declare (ignore type args)) #'(lambda (string location &optional (offset 0)) (assert (null-pointer-p (sap-ref-sap location offset))) (setf (sap-ref-sap location offset) + #+cmu (copy-memory - (make-pointer (1+ (kernel:get-lisp-obj-address string))) - (1+ (length string)))))) + (vector-sap (coerce string 'simple-base-string)) + (1+ (length string))) + #+sbcl + (let ((utf8 (%deport-utf8-string string))) + (copy-memory (vector-sap utf8) (length utf8)))))) (defmethod reader-function ((type (eql 'string)) &rest args) (declare (ignore type args)) #'(lambda (location &optional (offset 0)) (unless (null-pointer-p (sap-ref-sap location offset)) - (c-call::%naturalize-c-string (sap-ref-sap location offset))))) + #+cmu(%naturalize-c-string (sap-ref-sap location offset)) + #+sbcl(%naturalize-utf8-string (sap-ref-sap location offset))))) (defmethod destroy-function ((type (eql 'string)) &rest args) (declare (ignore type args)) @@ -522,6 +636,10 @@ (deallocate-memory (sap-ref-sap location offset)) (setf (sap-ref-sap location offset) (make-pointer 0))))) +(defmethod unbound-value ((type (eql 'string)) &rest args) + (declare (ignore type args)) + (values t nil)) + (defmethod alien-type ((type (eql 'pathname)) &rest args) (declare (ignore type args)) @@ -577,6 +695,10 @@ (declare (ignore type args)) (destroy-function 'string)) +(defmethod unbound-value ((type (eql 'pathname)) &rest args) + (declare (ignore type args)) + (unbound-value 'string)) + (defmethod alien-type ((type (eql 'boolean)) &rest args) (apply #'alien-type 'signed-byte args)) @@ -688,10 +810,96 @@ (defmethod alien-type ((type (eql 'nil)) &rest args) (declare (ignore type args)) - 'c-call:void) + 'void) (defmethod from-alien-function ((type (eql 'nil)) &rest args) (declare (ignore type args)) #'(lambda (value) (declare (ignore value)) (values))) + + +(defmethod alien-type ((type (eql 'copy-of)) &rest args) + (declare (ignore type)) + (alien-type (first args))) + +(defmethod size-of ((type (eql 'copy-of)) &rest args) + (declare (ignore type)) + (size-of (first args))) + +(defmethod to-alien-form (form (type (eql 'copy-of)) &rest args) + (declare (ignore type)) + (copy-to-alien-form form (first args))) + +(defmethod to-alien-function ((type (eql 'copy-of)) &rest args) + (declare (ignore type)) + (copy-to-alien-function (first args))) + +(defmethod from-alien-form (form (type (eql 'copy-of)) &rest args) + (declare (ignore type)) + (copy-from-alien-form form (first args))) + +(defmethod from-alien-function ((type (eql 'copy-of)) &rest args) + (declare (ignore type)) + (copy-from-alien-function (first args))) + +(defmethod reader-function ((type (eql 'copy-of)) &rest args) + (declare (ignore type)) + (reader-function (first args))) + +(defmethod writer-function ((type (eql 'copy-of)) &rest args) + (declare (ignore type)) + (writer-function (first args))) + + +(defmethod alien-type ((type (eql 'callback)) &rest args) + (declare (ignore type args)) + (alien-type 'pointer)) + +(defmethod size-of ((type (eql 'callback)) &rest args) + (declare (ignore type args)) + (size-of 'pointer)) + +(defmethod to-alien-form (callback (type (eql 'callback)) &rest args) + (declare (ignore type args)) + #+cmu `(callback ,callback) + #+sbcl `(sb-alien:alien-function-sap ,callback)) + +(defmethod to-alien-function ((type (eql 'callback)) &rest args) + (declare (ignore type args)) + #+cmu #'(lambda (callback) (callback callback)) + #+sbcl #'sb-alien:alien-function-sap) + +#+cmu +(defun find-callback (pointer) + (find pointer alien::*callbacks* :key #'callback-trampoline :test #'sap=)) + +(defmethod from-alien-form (pointer (type (eql 'callback)) &rest args) + (declare (ignore type args)) + #+cmu `(find-callback ,pointer) + #+sbcl `(sb-alien::%find-alien-function ,pointer)) + +(defmethod from-alien-function ((type (eql 'callback)) &rest args) + (declare (ignore type args)) + #+cmu #'find-callback + #+sbcl #'sb-alien::%find-alien-function) + +(defmethod writer-function ((type (eql 'callback)) &rest args) + (declare (ignore type args)) + (let ((writer (writer-function 'pointer)) + (to-alien (to-alien-function 'callback))) + #'(lambda (callback location &optional (offset 0)) + (funcall writer (funcall to-alien callback) location offset)))) + +(defmethod reader-function ((type (eql 'callback)) &rest args) + (declare (ignore type args)) + (let ((reader (reader-function 'pointer)) + (from-alien (from-alien-function 'callback))) + #'(lambda (location &optional (offset 0)) + (let ((pointer (funcall reader location offset))) + (unless (null-pointer-p pointer) + (funcall from-alien pointer)))))) + +(defmethod unbound-value ((type (eql 'callback)) &rest args) + (declare (ignore type args)) + (values t nil))