X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/3840beb25c5aefcb3b8b1d101b50d6f8dd90b6f0..e0d2987b2876e68b8d1052600c3f2281b5b60ec6:/glib/ffi.lisp diff --git a/glib/ffi.lisp b/glib/ffi.lisp index 7580646..bd68c1e 100644 --- a/glib/ffi.lisp +++ b/glib/ffi.lisp @@ -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.4 2004-11-09 10:04:35 espen Exp $ +;; $Id: ffi.lisp,v 1.12 2005-01-03 16:35:05 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*))) @@ -96,11 +103,11 @@ (not supplied-lambda-list) (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)) @@ -234,10 +241,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) @@ -294,9 +309,21 @@ (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)) @@ -316,6 +343,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 @@ -347,7 +378,7 @@ (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args) (destructuring-bind (&optional (size '*)) args (ecase size - (#.+bits-of-byte+ '(unsigned-byte 8)) + (#.+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)))) @@ -392,6 +423,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)) @@ -427,7 +466,7 @@ (defmethod size-of ((type (eql 'double-float)) &rest args) (declare (ignore type args)) - +size-of-float+) + +size-of-double+) (defmethod writer-function ((type (eql 'double-float)) &rest args) (declare (ignore type args)) @@ -486,13 +525,17 @@ (declare (ignore type args)) `(let ((string ,string)) (unless (null-pointer-p string) - (c-call::%naturalize-c-string string)))) + (prog1 + (c-call::%naturalize-c-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 + (c-call::%naturalize-c-string string) + (deallocate-memory string))))) (defmethod cleanup-form (string (type (eql 'string)) &rest args) (declare (ignore type args)) @@ -506,6 +549,18 @@ (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) + (c-call::%naturalize-c-string string)))) + +(defmethod copy-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)))) + (defmethod writer-function ((type (eql 'string)) &rest args) (declare (ignore type args)) #'(lambda (string location &optional (offset 0)) @@ -528,6 +583,9 @@ (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)) @@ -583,6 +641,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)) @@ -701,3 +763,38 @@ #'(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))) + +(export 'copy-of)