X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/8755b1a5d37f2f4b853c01f0d8b121ab9ee4093a..60e5d93717c275307c88ff03cca7492e8c775d72:/glib/ffi.lisp?ds=sidebyside diff --git a/glib/ffi.lisp b/glib/ffi.lisp index 46f69de..e7bbd95 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.3 2004-11-07 01:23:38 espen Exp $ +;; $Id: ffi.lisp,v 1.6 2004-11-19 13:02:51 espen Exp $ (in-package "GLIB") @@ -90,11 +90,11 @@ (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) @@ -109,30 +109,36 @@ #+cmu (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args) (ext:collect ((alien-types) (alien-bindings) (alien-parameters) - (alien-values) (cleanup-forms)) + (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 + ,@(when (eq style :in-out) + (list (to-alien-form expr type))))) + (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)))) @@ -150,12 +156,12 @@ (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 @@ -228,6 +234,11 @@ (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 ()) @@ -291,6 +302,18 @@ #'(lambda (location 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)) @@ -386,6 +409,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)) @@ -480,13 +511,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)) @@ -500,6 +535,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)) @@ -695,3 +742,30 @@ #'(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))) + +(export 'copy-of)