From 7479d92c2e0ee576d0d376bbbbb72a9dcb948e4b Mon Sep 17 00:00:00 2001 Message-Id: <7479d92c2e0ee576d0d376bbbbb72a9dcb948e4b.1714799159.git.mdw@distorted.org.uk> From: Mark Wooding Date: Mon, 30 Apr 2001 11:25:25 +0000 Subject: [PATCH] Added platform independent MKBINDING to create bindings at run-time Organization: Straylight/Edgeware From: espen --- glib/gboxed.lisp | 11 +++++------ glib/gforeign.lisp | 30 ++++++++++++++++++++++++++++-- glib/glib-package.lisp | 7 ++++--- glib/gtype.lisp | 25 ++++++------------------- glib/proxy.lisp | 36 ++++++------------------------------ 5 files changed, 49 insertions(+), 60 deletions(-) diff --git a/glib/gboxed.lisp b/glib/gboxed.lisp index 1bf2916..e2dac5c 100644 --- a/glib/gboxed.lisp +++ b/glib/gboxed.lisp @@ -15,13 +15,13 @@ ;; 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: gboxed.lisp,v 1.1 2001-04-29 20:19:25 espen Exp $ +;; $Id: gboxed.lisp,v 1.2 2001-04-30 11:25:25 espen Exp $ (in-package "GLIB") (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass boxed (alien-structure) + (defclass boxed (proxy) () (:metaclass proxy-class))) @@ -85,16 +85,15 @@ (defmethod shared-initialize ((class boxed-class) names "Specify either :type-init or :alien-name for class ~A" class-name)) (alien-name (type-number-from-alien-name (first alien-name))) - (type-init - (funcall (alien-function (first type-init) '(unsigned 32)))) + (type-init (funcall (mkbinding (first type-init) 'type-number))) (t (or (type-number-from-alien-name (default-alien-type-name class-name) nil) (funcall - (alien-function + (mkbinding (default-alien-fname (format nil "~A_get_type" class-name)) - '(unsigned 32)))))))) + 'type-number))))))) (setf (find-type-number class) type-number))) diff --git a/glib/gforeign.lisp b/glib/gforeign.lisp index 5612b54..f70dfad 100644 --- a/glib/gforeign.lisp +++ b/glib/gforeign.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: gforeign.lisp,v 1.6 2001-04-29 20:05:22 espen Exp $ +;; $Id: gforeign.lisp,v 1.7 2001-04-30 11:25:25 espen Exp $ (in-package "GLIB") @@ -364,7 +364,26 @@ (defun %defbinding (foreign-name lisp-name lambda-list ,@(alien-deallocators) (values ,@(alien-values))))))))) - + +(defun mkbinding (name rettype &rest types) + (declare (optimize (ext:inhibit-warnings 3))) + (let* ((ftype + `(function ,@(mapcar #'translate-type-spec (cons rettype types)))) + (alien + (alien::%heap-alien + (alien::make-heap-alien-info + :type (alien::parse-alien-type ftype) + :sap-form (system:foreign-symbol-address name)))) + (translate-arguments (mapcar #'intern-return-value-translator types)) + (translate-return-value (intern-return-value-translator rettype)) + (cleanup-arguments (mapcar #'intern-cleanup-function types))) + + #'(lambda (&rest args) + (map-into args #'funcall translate-arguments args) + (prog1 + (funcall + translate-return-value (apply #'alien:alien-funcall alien args)) + (mapc #'funcall cleanup-arguments args))))) ;;;; Definitons and translations of fundamental types @@ -607,6 +626,7 @@ (deftype-method cleanup-alien string (type-spec c-string &optional weak-ref) (unreference-alien type-spec c-string))) (deftype-method unreference-alien string (type-spec c-string) + (declare (ignore type-spec)) `(let ((c-string ,c-string)) (unless (null-pointer-p c-string) (deallocate-memory c-string)))) @@ -683,3 +703,9 @@ (deftype-method translate-to-alien null (type-spec expr &optional weak-ref) (deftype-method translate-type-spec nil (type-spec) (declare (ignore type-spec)) 'void) + +(deftype-method translate-from-alien nil (type-spec expr &optional weak-ref) + (declare (ignore type-spec weak-ref)) + `(progn + ,expr + (values))) diff --git a/glib/glib-package.lisp b/glib/glib-package.lisp index b68b322..3de4e27 100644 --- a/glib/glib-package.lisp +++ b/glib/glib-package.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: glib-package.lisp,v 1.4 2001-04-29 20:33:53 espen Exp $ +;; $Id: glib-package.lisp,v 1.5 2001-04-30 11:25:25 espen Exp $ (export 'kernel::type-expand-1 "KERNEL") @@ -29,9 +29,10 @@ (defpackage "GLIB" (:export "DEFTYPE-METHOD" "TRANSLATE-TYPE-SPEC" "TRANSLATE-TO-ALIEN" "TRANSLATE-FROM-ALIEN" "CLEANUP-ALIEN" "UNREFERENCE-ALIEN" "SIZE-OF") - (:export "DEFBINDING" "DEFINE-FOREIGN" "USE-PREFIX" "PACKAGE-PREFIX") + (:export "DEFBINDING" "DEFINE-FOREIGN" "MKBINDING" "USE-PREFIX" + "PACKAGE-PREFIX") (:export "LONG" "UNSIGNED-LONG" "INT" "UNSIGNED-INT" "SHORT" "UNSIGNED-SHORT" - "SIGNED" "UNSIGNED" "CHAR" "POINTER" "ENUM" "FLAGS") + "SIGNED" "UNSIGNED" "CHAR" "POINTER") (:export "INTERN-ARGUMENT-TRANSLATOR" "INTERN-RETURN-VALUE-TRANSLATOR" "INTERN-CLEANUP-FUNCTION" "INTERN-WRITER-FUNCTION" "INTERN-READER-FUNCTION" "INTERN-DESTROY-FUNCTION")) diff --git a/glib/gtype.lisp b/glib/gtype.lisp index 346ea61..9cd2319 100644 --- a/glib/gtype.lisp +++ b/glib/gtype.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: gtype.lisp,v 1.8 2001-04-29 20:17:07 espen Exp $ +;; $Id: gtype.lisp,v 1.9 2001-04-30 11:25:25 espen Exp $ (in-package "GLIB") @@ -109,24 +109,11 @@ (defun type-from-number (type-number) (defun type-number-of (object) (find-type-number (type-of object))) -(defun alien-function (name return-type &rest arg-types) - (let ((alien - (alien::%heap-alien - (alien::make-heap-alien-info - :type (alien::parse-alien-type - `(function ,@(cons return-type arg-types))) - :sap-form (system:foreign-symbol-address name))))) - #'(lambda (&rest args) - (apply #'alien:alien-funcall alien args)))) - - (defun type-init (name &optional init-fname) (funcall - (alien-function - (or - init-fname - (default-alien-fname (format nil "~A_get_type" name))) - '(unsigned 32)))) + (mkbinding + (or init-fname (default-alien-fname (format nil "~A_get_type" name))) + 'type-number))) ;;;; Superclass for wrapping types in the glib type system @@ -218,11 +205,11 @@ (default-alien-type-name class-name) nil) (when ref (setf (slot-value class 'ref) - (alien-function (first ref) 'system-area-pointer 'system-area-pointer))) + (mkbinding (first ref) 'pointer 'pointer))) (when unref (setf (slot-value class 'unref) - (alien-function (first unref) 'void 'system-area-pointer))))) + (mkbinding (first unref) 'nil 'pointer))))) (defmethod shared-initialize :after ((class ginstance-class) names &rest initargs) diff --git a/glib/proxy.lisp b/glib/proxy.lisp index f4c5a59..b4ff7a3 100644 --- a/glib/proxy.lisp +++ b/glib/proxy.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: proxy.lisp,v 1.1 2001-04-29 20:19:25 espen Exp $ +;; $Id: proxy.lisp,v 1.2 2001-04-30 11:25:25 espen Exp $ (in-package "GLIB") @@ -278,43 +278,19 @@ (defmethod compute-virtual-slot-location ((class proxy-class) (slotd effective-virtual-alien-slot-definition) direct-slotds) - (let ((location (call-next-method))) + (let ((location (call-next-method)) + (class-name (class-name class))) (if (or (stringp location) (consp location)) (destructuring-bind (reader &optional writer) (mklist location) (with-slots (type) slotd (list (if (stringp reader) - (let* ((alien-type (translate-type-spec type)) - (alien - (alien::%heap-alien - (alien::make-heap-alien-info - :type (alien::parse-alien-type - `(function ,alien-type system-area-pointer)) - :sap-form (system:foreign-symbol-address reader)))) - (translate-return-value - (intern-return-value-translator type))) - #'(lambda (object) - (funcall - translate-return-value - (alien-funcall - alien (proxy-location object))))) + (mkbinding reader type class-name) reader) (if (stringp writer) - (let* ((alien-type (translate-type-spec type)) - (alien - (alien::%heap-alien - (alien::make-heap-alien-info - :type (alien::parse-alien-type - `(function - void system-area-pointer ,alien-type)) - :sap-form (system:foreign-symbol-address writer)))) - (translate-argument (intern-argument-translator type)) - (cleanup (intern-cleanup-function type))) + (let ((writer (mkbinding writer 'nil class-name type))) #'(lambda (value object) - (let ((tmp (funcall translate-argument value)) - (location (proxy-location object))) - (alien-funcall alien location tmp) - (funcall cleanup tmp)))) + (funcall writer object value))) writer)))) location))) -- [mdw]