From: espen Date: Sun, 26 Feb 2006 15:30:00 +0000 (+0000) Subject: Type method system redesigned X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/commitdiff_plain/75689fea8b73ccc1e8cb32b671b7fd881da40cf3 Type method system redesigned --- diff --git a/glib/defpackage.lisp b/glib/defpackage.lisp index 5512823..e101621 100644 --- a/glib/defpackage.lisp +++ b/glib/defpackage.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: defpackage.lisp,v 1.11 2006-02-19 19:18:31 espen Exp $ +;; $Id: defpackage.lisp,v 1.12 2006-02-26 15:30:00 espen Exp $ ;(export 'kernel::type-expand-1 "KERNEL") @@ -45,9 +45,14 @@ (defpackage "GLIB" #+cmu(:import-from "C-CALL" "%NATURALIZE-C-STRING" "VOID") #+sbcl(:import-from "SB-ALIEN" "%NATURALIZE-UTF8-STRING" "%DEPORT-UTF8-STRING" "VOID") - (:export "DEFTYPE-METHOD" "TRANSLATE-TYPE-SPEC" "TRANSLATE-TO-ALIEN" - "TRANSLATE-FROM-ALIEN" "CLEANUP-ALIEN" "UNREFERENCE-ALIEN" - "SIZE-OF" "UNBOUND-VALUE") + (:export "DEFINE-TYPE-METHOD" "DEFINE-TYPE-GENERIC" + "ALIEN-TYPE" "SIZE-OF" "TO-ALIEN-FORM" "FROM-ALIEN-FORM" + "CLEANUP-FORM" "CALLBACK-FROM-ALIEN-FORM" "CALLBACK-CLEANUP-FORM" + "TO-ALIEN-FUNCTION" "FROM-ALIEN-FUNCTION" "CLEANUP-FUNCTION" + "COPY-TO-ALIEN-FORM" "COPY-TO-ALIEN-FUNCTION" + "COPY-FROM-ALIEN-FORM" "COPY-FROM-ALIEN-FUNCTION" + "WRITER-FUNCTION" "READER-FUNCTION" "DESTROY-FUNCTION" + "UNBOUND-VALUE") (:export "DEFBINDING" "DEFINE-FOREIGN" "MKBINDING" "USE-PREFIX" "PACKAGE-PREFIX" "DEFCALLBACK" "CALLBACK" "CALL-NEXT-HANDLER" "DEFINE-CALLBACK" "CALLBACK-ADDRESS" "USER-DATA-DESTROY-CALLBACK") diff --git a/glib/export.lisp b/glib/export.lisp index 8ac31bb..d88149e 100644 --- a/glib/export.lisp +++ b/glib/export.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: export.lisp,v 1.5 2005-04-23 16:48:50 espen Exp $ +;; $Id: export.lisp,v 1.6 2006-02-26 15:30:00 espen Exp $ ;;; Autogenerating exported symbols @@ -34,7 +34,7 @@ (defexport defbinding (name &rest args) name (first name))) - (defexport def-type-method (name &rest args) + (defexport define-type-generic (name &rest args) (declare (ignore args)) name) diff --git a/glib/ffi.lisp b/glib/ffi.lisp index 2d24742..6be6298 100644 --- a/glib/ffi.lisp +++ b/glib/ffi.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: ffi.lisp,v 1.25 2006-02-19 22:25:31 espen Exp $ +;; $Id: ffi.lisp,v 1.26 2006-02-26 15:30:00 espen Exp $ (in-package "GLIB") @@ -112,7 +112,7 @@ (defmacro defbinding (name lambda-list return-type &rest docs/args) ((and (namep expr) (eq style :out)) expr) ((namep expr) (make-symbol (string expr))) ((gensym))) - expr (mklist type) style) args))))) + expr type style) args))))) (%defbinding c-name lisp-name (or supplied-lambda-list (nreverse lambda-list)) @@ -125,7 +125,7 @@ (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args) (dolist (arg args) (destructuring-bind (var expr type style) arg (let ((declaration (alien-type type)) - (cleanup (cleanup-form var type))) + (cleanup (cleanup-form type var))) (cond ((member style '(:out :in-out)) @@ -134,25 +134,25 @@ (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args) (alien-bindings `(,var ,declaration ,@(cond - ((eq style :in-out) (list (to-alien-form expr type))) + ((eq style :in-out) (list (to-alien-form type expr))) ((eq declaration 'system-area-pointer) (list '(make-pointer 0)))))) - (return-values (from-alien-form var type))) + (return-values (from-alien-form type var))) ((eq style :return) (alien-types declaration) (alien-bindings - `(,var ,declaration ,(to-alien-form expr type))) + `(,var ,declaration ,(to-alien-form type expr))) (alien-parameters var) - (return-values (from-alien-form var type))) + (return-values (from-alien-form type var))) (cleanup (alien-types declaration) (alien-bindings - `(,var ,declaration ,(to-alien-form expr type))) + `(,var ,declaration ,(to-alien-form type expr))) (alien-parameters var) (cleanup-forms cleanup)) (t (alien-types declaration) - (alien-parameters (to-alien-form expr type))))))) + (alien-parameters (to-alien-form type expr))))))) (let* ((alien-name (make-symbol (string lisp-name))) (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters)))) @@ -169,7 +169,7 @@ (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args) ,(if return-type `(values (unwind-protect - ,(from-alien-form alien-funcall return-type) + ,(from-alien-form return-type alien-funcall) ,@(cleanup-forms)) ,@(return-values)) `(progn @@ -222,27 +222,27 @@ (defmacro define-callback (name return-type args &body body) ((eq (caar body) 'declare) (values nil (first body) (rest body))) (t (values nil nil body))) - `(,define-callback ,name - #+(and sbcl alien-callbacks),(alien-type return-type) - (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type) - ,@(mapcar #'(lambda (arg) - (destructuring-bind (name type) arg - `(,name ,(alien-type type)))) - args)) - ,@(when doc (list doc)) - ,(to-alien-form - `(let (,@(loop + `(progn + #+cmu(defparameter ,name nil) + (,define-callback ,name + #+(and sbcl alien-callbacks),(alien-type return-type) + (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type) + ,@(mapcar #'(lambda (arg) + (destructuring-bind (name type) arg + `(,name ,(alien-type type)))) + args)) + ,@(when doc (list doc)) + ,(to-alien-form return-type + `(let (,@(loop + for (name type) in args + as from-alien-form = (callback-from-alien-form type name) + collect `(,name ,from-alien-form))) + ,@(when declaration (list declaration)) + (unwind-protect + (progn ,@body) + ,@(loop for (name type) in args - as from-alien-form = (callback-from-alien-form name type) - collect `(,name ,from-alien-form))) - ,@(when declaration (list declaration)) - (unwind-protect - (progn ,@body) - ,@(loop - for (name type) in args - do (callback-cleanup-form name type)))) - - return-type))))) + do (callback-cleanup-form type name)))))))))) (defun callback-address (callback) #+cmu(alien::callback-trampoline callback) @@ -266,50 +266,131 @@ (defun callback (callback) -;;;; Definitons and translations of fundamental types - -(defmacro def-type-method (name args &optional documentation) - `(progn - (defgeneric ,name (,@args type &rest args) - ,@(when documentation `((:documentation ,documentation)))) - (defmethod ,name (,@args (type symbol) &rest args) - (let ((class (find-class type nil))) - (if (typep class 'standard-class) - (apply #',name ,@args class args) - (multiple-value-bind (super-type expanded-p) - (type-expand-1 (cons type args)) - (if expanded-p - (,name ,@args super-type) - (call-next-method)))))) - (defmethod ,name (,@args (type cons) &rest args) - (declare (ignore args)) - (apply #',name ,@args (first type) (rest type))))) - - -(def-type-method alien-type ()) -(def-type-method size-of ()) -(def-type-method to-alien-form (form)) -(def-type-method from-alien-form (form)) -(def-type-method cleanup-form (form) +;;;; The "type method" system + +(defun find-applicable-type-method (name type-spec &optional (error-p t)) + (let ((type-methods (get name 'type-methods))) + (labels ((search-method-in-cpl-order (classes) + (when classes + (or + (gethash (class-name (first classes)) type-methods) + (search-method-in-cpl-order (rest classes))))) + (lookup-method (type-spec) + (if (and (symbolp type-spec) (find-class type-spec nil)) + (search-method-in-cpl-order + (class-precedence-list (find-class type-spec))) + (or + (let ((specifier (etypecase type-spec + (symbol type-spec) + (list (first type-spec))))) + (gethash specifier type-methods)) + (multiple-value-bind (expanded-type expanded-p) + (type-expand-1 type-spec) + (when expanded-p + (lookup-method expanded-type)))))) + (search-built-in-type-hierarchy (sub-tree) + (when (subtypep type-spec (first sub-tree)) + (or + (search-nodes (cddr sub-tree)) + (second sub-tree)))) + (search-nodes (nodes) + (loop + for node in nodes + as function = (search-built-in-type-hierarchy node) + until function + finally (return function)))) + (or + (lookup-method type-spec) + ;; This is to handle unexpandable types whichs doesn't name a class + (unless (and (symbolp type-spec) (find-class type-spec nil)) + (search-nodes (get name 'built-in-type-hierarchy))) + (and + error-p + (error "No applicable type method for ~A when call width type specifier ~A" name type-spec)))))) + + +(defun insert-type-in-hierarchy (specifier function nodes) + (cond + ((let ((node (find specifier nodes :key #'first))) + (when node + (setf (second node) function) + nodes))) + ((let ((node + (find-if + #'(lambda (node) + (subtypep specifier (first node))) + nodes))) + (when node + (setf (cddr node) + (insert-type-in-hierarchy specifier function (cddr node))) + nodes))) + ((let ((sub-nodes (remove-if-not + #'(lambda (node) + (subtypep (first node) specifier)) + nodes))) + (cons + (list* specifier function sub-nodes) + (nset-difference nodes sub-nodes)))))) + + +(defun add-type-method (name specifier function) + (setf (gethash specifier (get name 'type-methods)) function) + (when (typep (find-class specifier nil) 'built-in-class) + (setf (get name 'built-in-type-hierarchy) + (insert-type-in-hierarchy specifier function + (get name 'built-in-type-hierarchy))))) + + +;; TODO: handle optional, key and rest arguments +(defmacro define-type-generic (name lambda-list &optional documentation) + (if (or + (not lambda-list) + (find (first lambda-list) '(&optional &key &rest &allow-other-keys))) + (error "A type generic needs at least one required argument") + `(progn + (setf (get ',name 'type-methods) (make-hash-table)) + (setf (get ',name 'built-in-type-hierarchy) ()) + (defun ,name ,lambda-list + ,documentation + (funcall + (find-applicable-type-method ',name ,(first lambda-list)) + ,@lambda-list))))) + + +(defmacro define-type-method (name lambda-list &body body) + (let ((specifier (cadar lambda-list)) + (args (cons (caar lambda-list) (rest lambda-list)))) + `(progn + (add-type-method ',name ',specifier #'(lambda ,args ,@body)) + ',name))) + + + +;;;; Definitons and translations of fundamental types + +(define-type-generic alien-type (type-spec)) +(define-type-generic size-of (type-spec)) +(define-type-generic to-alien-form (type-spec form)) +(define-type-generic from-alien-form (type-spec form)) +(define-type-generic cleanup-form (type-spec form) "Creates a form to clean up after the alien call has finished.") -(def-type-method callback-from-alien-form (form)) -(def-type-method callback-cleanup-form (form)) +(define-type-generic callback-from-alien-form (type-spec form)) +(define-type-generic callback-cleanup-form (type-spec form)) -(def-type-method to-alien-function ()) -(def-type-method from-alien-function ()) -(def-type-method cleanup-function ()) +(define-type-generic to-alien-function (type-spec)) +(define-type-generic from-alien-function (type-spec)) +(define-type-generic cleanup-function (type-spec)) -(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 ()) +(define-type-generic copy-to-alien-form (type-spec form)) +(define-type-generic copy-to-alien-function (type-spec)) +(define-type-generic copy-from-alien-form (type-spec form)) +(define-type-generic copy-from-alien-function (type-spec)) +(define-type-generic writer-function (type-spec)) +(define-type-generic reader-function (type-spec)) +(define-type-generic destroy-function (type-spec)) -(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") +(define-type-generic unbound-value (type-spec) + "Returns a value which should be intepreted as unbound for slots with virtual allocation") ;; Sizes of fundamental C types in bytes (8 bits) @@ -337,86 +418,114 @@ (deftype signed (&optional (size '*)) `(signed-byte ,size)) (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size)) (deftype char () 'base-char) (deftype pointer () 'system-area-pointer) -(deftype boolean (&optional (size '*)) (declare (ignore size)) `(member t nil)) -;(deftype invalid () nil) +(deftype boolean (&optional (size '*)) (declare (ignore size)) t) +(deftype copy-of (type) type) +(define-type-method alien-type ((type t)) + (error "No alien type corresponding to the type specifier ~A" type)) -(defmethod to-alien-form (form (type t) &rest args) - (declare (ignore type args)) - form) +(define-type-method to-alien-form ((type t) form) + (declare (ignore form)) + (error "Not a valid type specifier for arguments: ~A" type)) -(defmethod to-alien-function ((type t) &rest args) - (declare (ignore type args)) - #'identity) +(define-type-method to-alien-function ((type t)) + (error "Not a valid type specifier for arguments: ~A" type)) -(defmethod from-alien-form (form (type t) &rest args) - (declare (ignore type args)) - form) +(define-type-method from-alien-form ((type t) form) + (declare (ignore form)) + (error "Not a valid type specifier for return values: ~A" type)) -(defmethod from-alien-function ((type t) &rest args) - (declare (ignore type args)) - #'identity) +(define-type-method from-alien-function ((type t)) + (error "Not a valid type specifier for return values: ~A" type)) -(defmethod cleanup-form (form (type t) &rest args) - (declare (ignore form type args)) +(define-type-method cleanup-form ((type t) form) + (declare (ignore form type)) nil) -(defmethod cleanup-function ((type t) &rest args) - (declare (ignore type args)) +(define-type-method cleanup-function ((type t)) + (declare (ignore type)) #'identity) -;; This does not really work as def-type-method is badly broken and -;; needs a redesign, so we need to add a lots of redundant methods -(defmethod callback-from-alien-form (form (type t) &rest args) -; (apply #'copy-from-alien-form form type args)) - (apply #'from-alien-form form type args)) +(define-type-method callback-from-alien-form ((type t) form) + (copy-from-alien-form type form)) -(defmethod callback-cleanup-form (form (type t) &rest args) - (declare (ignore form type args)) +(define-type-method callback-cleanup-form ((type t) form) + (declare (ignore form type)) nil) -(defmethod destroy-function ((type t) &rest args) - (declare (ignore type args)) +(define-type-method destroy-function ((type t)) + (declare (ignore type)) #'(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)) +(define-type-method copy-to-alien-form ((type t) form) + (to-alien-form type form)) + +(define-type-method copy-to-alien-function ((type t)) + (to-alien-function type)) -(defmethod copy-to-alien-function ((type t) &rest args) - (apply #'to-alien-function type args)) +(define-type-method copy-from-alien-form ((type t) form) + (from-alien-form type form)) -(defmethod copy-from-alien-form (form (type t) &rest args) - (apply #'from-alien-form form type args)) +(define-type-method copy-from-alien-function ((type t)) + (from-alien-function type)) -(defmethod copy-from-alien-function ((type t) &rest args) - (apply #'from-alien-function type args)) -(defmethod alien-type ((type (eql 'signed-byte)) &rest args) +(define-type-method to-alien-form ((type real) form) (declare (ignore type)) - (destructuring-bind (&optional (size '*)) args + form) + +(define-type-method to-alien-function ((type real)) + (declare (ignore type)) + #'identity) + +(define-type-method from-alien-form ((type real) form) + (declare (ignore type)) + form) + +(define-type-method from-alien-function ((type real)) + (declare (ignore type)) + #'identity) + + +(define-type-method alien-type ((type integer)) + (declare (ignore type)) + (alien-type 'signed-byte)) + +(define-type-method size-of ((type integer)) + (declare (ignore type)) + (size-of 'signed-byte)) + +(define-type-method writer-function ((type integer)) + (declare (ignore type)) + (writer-function 'signed-byte)) + +(define-type-method reader-function ((type integer)) + (declare (ignore type)) + (reader-function 'signed-byte)) + + +(define-type-method alien-type ((type signed-byte)) + (destructuring-bind (&optional (size '*)) + (rest (mklist (type-expand-to 'signed-byte type))) (ecase size (#.+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)) - (destructuring-bind (&optional (size '*)) args +(define-type-method size-of ((type signed-byte)) + (destructuring-bind (&optional (size '*)) + (rest (mklist (type-expand-to 'signed-byte type))) (ecase size (#.+bits-of-byte+ 1) (#.+bits-of-short+ +size-of-short+) ((* #.+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 +(define-type-method writer-function ((type signed-byte)) + (destructuring-bind (&optional (size '*)) + (rest (mklist (type-expand-to 'signed-byte type))) (let ((size (if (eq size '*) +bits-of-int+ size))) (ecase size (8 #'(lambda (value location &optional (offset 0)) @@ -428,9 +537,9 @@ (defmethod writer-function ((type (eql 'signed-byte)) &rest args) (64 #'(lambda (value location &optional (offset 0)) (setf (signed-sap-ref-64 location offset) value))))))) -(defmethod reader-function ((type (eql 'signed-byte)) &rest args) - (declare (ignore type)) - (destructuring-bind (&optional (size '*)) args +(define-type-method reader-function ((type signed-byte)) + (destructuring-bind (&optional (size '*)) + (rest (mklist (type-expand-to 'signed-byte type))) (let ((size (if (eq size '*) +bits-of-int+ size))) (ecase size (8 #'(lambda (sap &optional (offset 0) weak-p) @@ -446,8 +555,10 @@ (defmethod reader-function ((type (eql 'signed-byte)) &rest args) (declare (ignore weak-p)) (signed-sap-ref-64 sap offset))))))) -(defmethod alien-type ((type (eql 'unsigned-byte)) &rest args) - (destructuring-bind (&optional (size '*)) args + +(define-type-method alien-type ((type unsigned-byte)) + (destructuring-bind (&optional (size '*)) + (rest (mklist (type-expand-to 'unsigned-byte type))) (ecase size (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8)) (#.+bits-of-short+ #+cmu 'c-call:unsigned-short @@ -457,12 +568,15 @@ (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args) (#.+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)) -(defmethod writer-function ((type (eql 'unsigned-byte)) &rest args) - (declare (ignore type)) - (destructuring-bind (&optional (size '*)) args +(define-type-method size-of ((type unsigned-byte)) + (destructuring-bind (&optional (size '*)) + (rest (mklist (type-expand-to 'unsigned-byte type))) + (size-of `(signed ,size)))) + +(define-type-method writer-function ((type unsigned-byte)) + (destructuring-bind (&optional (size '*)) + (rest (mklist (type-expand-to 'unsigned-byte type))) (let ((size (if (eq size '*) +bits-of-int+ size))) (ecase size (8 #'(lambda (value location &optional (offset 0)) @@ -474,9 +588,9 @@ (defmethod writer-function ((type (eql 'unsigned-byte)) &rest args) (64 #'(lambda (value location &optional (offset 0)) (setf (sap-ref-64 location offset) value))))))) -(defmethod reader-function ((type (eql 'unsigned-byte)) &rest args) - (declare (ignore type)) - (destructuring-bind (&optional (size '*)) args +(define-type-method reader-function ((type unsigned-byte)) + (destructuring-bind (&optional (size '*)) + (rest (mklist (type-expand-to 'unsigned-byte type))) (let ((size (if (eq size '*) +bits-of-int+ size))) (ecase size (8 #'(lambda (sap &optional (offset 0) weak-p) @@ -491,122 +605,111 @@ (defmethod reader-function ((type (eql 'unsigned-byte)) &rest args) (64 #'(lambda (sap &optional (offset 0) weak-p) (declare (ignore weak-p)) (sap-ref-64 sap offset))))))) - - -(defmethod alien-type ((type (eql 'integer)) &rest args) - (declare (ignore type args)) - (alien-type 'signed-byte)) - -(defmethod size-of ((type (eql 'integer)) &rest args) - (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)) - (alien-type 'signed-byte)) - -(defmethod size-of ((type (eql 'fixnum)) &rest args) - (declare (ignore type args)) - (size-of 'signed-byte)) - - -(defmethod alien-type ((type (eql 'single-float)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type single-float)) + (declare (ignore type)) #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float) -(defmethod size-of ((type (eql 'single-float)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type single-float)) + (declare (ignore type)) +size-of-float+) -(defmethod to-alien-form (form (type (eql 'single-float)) &rest args) - (declare (ignore type args)) +(define-type-method to-alien-form ((type single-float) form) + (declare (ignore type)) `(coerce ,form 'single-float)) -(defmethod to-alien-function ((type (eql 'single-float)) &rest args) - (declare (ignore type args)) +(define-type-method to-alien-function ((type single-float)) + (declare (ignore type)) #'(lambda (number) (coerce number 'single-float))) -(defmethod writer-function ((type (eql 'single-float)) &rest args) - (declare (ignore type args)) +(define-type-method writer-function ((type single-float)) + (declare (ignore type)) #'(lambda (value location &optional (offset 0)) (setf (sap-ref-single location offset) (coerce value 'single-float)))) -(defmethod reader-function ((type (eql 'single-float)) &rest args) - (declare (ignore type args)) +(define-type-method reader-function ((type single-float)) + (declare (ignore type)) #'(lambda (sap &optional (offset 0) weak-p) (declare (ignore weak-p)) (sap-ref-single sap offset))) -(defmethod alien-type ((type (eql 'double-float)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type double-float)) + (declare (ignore type)) #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float) -(defmethod size-of ((type (eql 'double-float)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type double-float)) + (declare (ignore type)) +size-of-double+) -(defmethod to-alien-form (form (type (eql 'double-float)) &rest args) - (declare (ignore type args)) +(define-type-method to-alien-form ((type double-float) form) + (declare (ignore type)) `(coerce ,form 'double-float)) -(defmethod to-alien-function ((type (eql 'double-float)) &rest args) - (declare (ignore type args)) +(define-type-method to-alien-function ((type double-float)) + (declare (ignore type)) #'(lambda (number) (coerce number 'double-float))) -(defmethod writer-function ((type (eql 'double-float)) &rest args) - (declare (ignore type args)) +(define-type-method writer-function ((type double-float)) + (declare (ignore type)) #'(lambda (value location &optional (offset 0)) (setf (sap-ref-double location offset) (coerce value 'double-float)))) -(defmethod reader-function ((type (eql 'double-float)) &rest args) - (declare (ignore type args)) +(define-type-method reader-function ((type double-float)) + (declare (ignore type)) #'(lambda (sap &optional (offset 0) weak-p) (declare (ignore weak-p)) (sap-ref-double sap offset))) -(defmethod alien-type ((type (eql 'base-char)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type base-char)) + (declare (ignore type)) #+cmu 'c-call:char #+sbcl 'sb-alien:char) -(defmethod size-of ((type (eql 'base-char)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type base-char)) + (declare (ignore type)) 1) -(defmethod writer-function ((type (eql 'base-char)) &rest args) - (declare (ignore type args)) +(define-type-method to-alien-form ((type base-char) form) + (declare (ignore type)) + form) + +(define-type-method to-alien-function ((type base-char)) + (declare (ignore type)) + #'identity) + +(define-type-method from-alien-form ((type base-char) form) + (declare (ignore type)) + form) + +(define-type-method from-alien-function ((type base-char)) + (declare (ignore type)) + #'identity) + +(define-type-method writer-function ((type base-char)) + (declare (ignore type)) #'(lambda (char location &optional (offset 0)) (setf (sap-ref-8 location offset) (char-code char)))) -(defmethod reader-function ((type (eql 'base-char)) &rest args) - (declare (ignore type args)) +(define-type-method reader-function ((type base-char)) + (declare (ignore type)) #'(lambda (location &optional (offset 0) weak-p) (declare (ignore weak-p)) (code-char (sap-ref-8 location offset)))) -(defmethod alien-type ((type (eql 'string)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type string)) + (declare (ignore type)) (alien-type 'pointer)) -(defmethod size-of ((type (eql 'string)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type string)) + (declare (ignore type)) (size-of 'pointer)) -(defmethod to-alien-form (string (type (eql 'string)) &rest args) - (declare (ignore type args)) +(define-type-method to-alien-form ((type string) string) + (declare (ignore type)) `(let ((string ,string)) ;; Always copy strings to prevent seg fault due to GC #+cmu @@ -617,8 +720,8 @@ (defmethod to-alien-form (string (type (eql 'string)) &rest args) (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)) +(define-type-method to-alien-function ((type string)) + (declare (ignore type)) #'(lambda (string) #+cmu (copy-memory @@ -628,11 +731,8 @@ (defmethod to-alien-function ((type (eql 'string)) &rest args) (let ((utf8 (%deport-utf8-string string))) (copy-memory (vector-sap utf8) (length utf8))))) -(defmethod callback-from-alien-form (form (type (eql 'string)) &rest args) - (apply #'copy-from-alien-form form type args)) - -(defmethod from-alien-form (string (type (eql 'string)) &rest args) - (declare (ignore type args)) +(define-type-method from-alien-form ((type string) string) + (declare (ignore type)) `(let ((string ,string)) (unless (null-pointer-p string) (prog1 @@ -640,8 +740,8 @@ (defmethod from-alien-form (string (type (eql 'string)) &rest args) #+sbcl(%naturalize-utf8-string string) (deallocate-memory string))))) -(defmethod from-alien-function ((type (eql 'string)) &rest args) - (declare (ignore type args)) +(define-type-method from-alien-function ((type string)) + (declare (ignore type)) #'(lambda (string) (unless (null-pointer-p string) (prog1 @@ -649,37 +749,34 @@ (defmethod from-alien-function ((type (eql 'string)) &rest args) #+sbcl(%naturalize-utf8-string string) (deallocate-memory string))))) -(defmethod cleanup-form (string (type (eql 'string)) &rest args) - (declare (ignore type args)) +(define-type-method cleanup-form ((type string) string) + (declare (ignore type)) `(let ((string ,string)) (unless (null-pointer-p string) (deallocate-memory string)))) -(defmethod cleanup-function ((type (eql 'string)) &rest args) - (declare (ignore args)) +(define-type-method cleanup-function ((type string)) + (declare (ignore type)) #'(lambda (string) (unless (null-pointer-p string) (deallocate-memory string)))) -(defmethod callback-from-alien-form (form (type (eql 'string)) &rest args) - (apply #'copy-from-alien-form form type args)) - -(defmethod copy-from-alien-form (string (type (eql 'string)) &rest args) - (declare (ignore type args)) +(define-type-method copy-from-alien-form ((type string) string) + (declare (ignore type)) `(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)) +(define-type-method copy-from-alien-function ((type string)) + (declare (ignore type)) #'(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)) +(define-type-method writer-function ((type string)) + (declare (ignore type)) #'(lambda (string location &optional (offset 0)) (assert (null-pointer-p (sap-ref-sap location offset))) (setf (sap-ref-sap location offset) @@ -691,70 +788,70 @@ (defmethod writer-function ((type (eql 'string)) &rest args) (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)) +(define-type-method reader-function ((type string)) + (declare (ignore type)) #'(lambda (location &optional (offset 0) weak-p) (declare (ignore weak-p)) (unless (null-pointer-p (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)) +(define-type-method destroy-function ((type string)) + (declare (ignore type)) #'(lambda (location &optional (offset 0)) (unless (null-pointer-p (sap-ref-sap location offset)) (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)) +(define-type-method unbound-value ((type string)) + (declare (ignore type)) + nil) -(defmethod alien-type ((type (eql 'pathname)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type pathname)) + (declare (ignore type)) (alien-type 'string)) -(defmethod size-of ((type (eql 'pathname)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type pathname)) + (declare (ignore type)) (size-of 'string)) -(defmethod to-alien-form (path (type (eql 'pathname)) &rest args) - (declare (ignore type args)) - (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string)) +(define-type-method to-alien-form ((type pathname) path) + (declare (ignore type)) + (to-alien-form 'string `(namestring (translate-logical-pathname ,path)))) -(defmethod to-alien-function ((type (eql 'pathname)) &rest args) - (declare (ignore type args)) +(define-type-method to-alien-function ((type pathname)) + (declare (ignore type)) (let ((string-function (to-alien-function 'string))) #'(lambda (path) (funcall string-function (namestring path))))) -(defmethod from-alien-form (string (type (eql 'pathname)) &rest args) - (declare (ignore type args)) - `(parse-namestring ,(from-alien-form string 'string))) +(define-type-method from-alien-form ((type pathname) string) + (declare (ignore type)) + `(parse-namestring ,(from-alien-form 'string string))) -(defmethod from-alien-function ((type (eql 'pathname)) &rest args) - (declare (ignore type args)) +(define-type-method from-alien-function ((type pathname)) + (declare (ignore type)) (let ((string-function (from-alien-function 'string))) #'(lambda (string) (parse-namestring (funcall string-function string))))) -(defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args) - (declare (ignore type args)) - (cleanup-form string 'string)) +(define-type-method cleanup-form ((type pathnanme) string) + (declare (ignore type)) + (cleanup-form 'string string)) -(defmethod cleanup-function ((type (eql 'pathnanme)) &rest args) - (declare (ignore type args)) +(define-type-method cleanup-function ((type pathnanme)) + (declare (ignore type)) (cleanup-function 'string)) -(defmethod writer-function ((type (eql 'pathname)) &rest args) - (declare (ignore type args)) +(define-type-method writer-function ((type pathname)) + (declare (ignore type)) (let ((string-writer (writer-function 'string))) #'(lambda (path location &optional (offset 0)) (funcall string-writer (namestring path) location offset)))) -(defmethod reader-function ((type (eql 'pathname)) &rest args) - (declare (ignore type args)) +(define-type-method reader-function ((type pathname)) + (declare (ignore type)) (let ((string-reader (reader-function 'string))) #'(lambda (location &optional (offset 0) weak-p) (declare (ignore weak-p)) @@ -762,222 +859,178 @@ (defmethod reader-function ((type (eql 'pathname)) &rest args) (when string (parse-namestring string)))))) -(defmethod destroy-function ((type (eql 'pathname)) &rest args) - (declare (ignore type args)) +(define-type-method destroy-function ((type pathname)) + (declare (ignore type)) (destroy-function 'string)) -(defmethod unbound-value ((type (eql 'pathname)) &rest args) - (declare (ignore type args)) +(define-type-method unbound-value ((type pathname)) + (declare (ignore type)) (unbound-value 'string)) -(defmethod alien-type ((type (eql 'boolean)) &rest args) - (apply #'alien-type 'signed-byte args)) +(define-type-method alien-type ((type boolean)) + (destructuring-bind (&optional (size '*)) + (rest (mklist (type-expand-to 'boolean type))) + (alien-type `(signed-byte ,size)))) -(defmethod size-of ((type (eql 'boolean)) &rest args) - (apply #'size-of 'signed-byte args)) +(define-type-method size-of ((type boolean)) + (destructuring-bind (&optional (size '*)) + (rest (mklist (type-expand-to 'boolean type))) + (size-of `(signed-byte ,size)))) -(defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args) - (declare (ignore type args)) +(define-type-method to-alien-form ((type boolean) boolean) + (declare (ignore type)) `(if ,boolean 1 0)) -(defmethod to-alien-function ((type (eql 'boolean)) &rest args) - (declare (ignore type args)) +(define-type-method to-alien-function ((type boolean)) + (declare (ignore type)) #'(lambda (boolean) (if boolean 1 0))) -(defmethod callback-from-alien-form (form (type (eql 'boolean)) &rest args) - (apply #'from-alien-form form type args)) - -(defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args) - (declare (ignore type args)) +(define-type-method from-alien-form ((type boolean) boolean) + (declare (ignore type)) `(not (zerop ,boolean))) -(defmethod from-alien-function ((type (eql 'boolean)) &rest args) - (declare (ignore type args)) +(define-type-method from-alien-function ((type boolean)) + (declare (ignore type)) #'(lambda (boolean) (not (zerop boolean)))) -(defmethod writer-function ((type (eql 'boolean)) &rest args) - (declare (ignore type)) - (let ((writer (apply #'writer-function 'signed-byte args))) - #'(lambda (boolean location &optional (offset 0)) - (funcall writer (if boolean 1 0) location offset)))) - -(defmethod reader-function ((type (eql 'boolean)) &rest args) - (declare (ignore type)) - (let ((reader (apply #'reader-function 'signed-byte args))) - #'(lambda (location &optional (offset 0) weak-p) - (declare (ignore weak-p)) - (not (zerop (funcall reader location offset)))))) - - -(defmethod alien-type ((type (eql 'or)) &rest args) - (let ((alien-type (alien-type (first args)))) +(define-type-method writer-function ((type boolean)) + (destructuring-bind (&optional (size '*)) + (rest (mklist (type-expand-to 'boolean type))) + (let ((writer (writer-function `(signed-byte ,size)))) + #'(lambda (boolean location &optional (offset 0)) + (funcall writer (if boolean 1 0) location offset))))) + +(define-type-method reader-function ((type boolean)) + (destructuring-bind (&optional (size '*)) + (rest (mklist (type-expand-to 'boolean type))) + (let ((reader (reader-function `(signed-byte ,size)))) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) + (not (zerop (funcall reader location offset))))))) + + +(define-type-method alien-type ((type or)) + (let* ((expanded-type (type-expand-to 'or type)) + (alien-type (alien-type (second expanded-type)))) (unless (every #'(lambda (type) (eq alien-type (alien-type type))) - (rest args)) - (error "No common alien type specifier for union type: ~A" - (cons type args))) + (cddr expanded-type)) + (error "No common alien type specifier for union type: ~A" type)) alien-type)) -(defmethod size-of ((type (eql 'or)) &rest args) - (declare (ignore type)) - (size-of (first args))) +(define-type-method size-of ((type or)) + (size-of (second (type-expand-to 'or type)))) -(defmethod to-alien-form (form (type (eql 'or)) &rest args) - (declare (ignore type)) +(define-type-method to-alien-form ((type or) form) `(let ((value ,form)) - (etypecase value - ,@(mapcar - #'(lambda (type) - `(,type ,(to-alien-form 'value type))) - args)))) - -(defmethod to-alien-function ((type (eql 'or)) &rest types) - (declare (ignore type)) - (let ((functions (mapcar #'to-alien-function types))) + (etypecase value + ,@(mapcar + #'(lambda (type) + `(,type ,(to-alien-form type 'value))) + (rest (type-expand-to 'or type)))))) + +(define-type-method to-alien-function ((type or)) + (let* ((expanded-type (type-expand-to 'or type)) + (functions (mapcar #'to-alien-function (rest expanded-type)))) #'(lambda (value) (loop for function in functions - for type in types - when (typep value type) + for alt-type in (rest expanded-type) + when (typep value alt-type) do (return (funcall function value)) - finally (error "~S is not of type ~A" value `(or ,@types)))))) + finally (error "~S is not of type ~A" value type))))) + -(defmethod alien-type ((type (eql 'system-area-pointer)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type pointer)) + (declare (ignore type)) 'system-area-pointer) -(defmethod size-of ((type (eql 'system-area-pointer)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type pointer)) + (declare (ignore type)) +size-of-pointer+) -(defmethod writer-function ((type (eql 'system-area-pointer)) &rest args) - (declare (ignore type args)) +(define-type-method to-alien-form ((type pointer) form) + (declare (ignore type)) + form) + +(define-type-method to-alien-function ((type pointer)) + (declare (ignore type)) + #'identity) + +(define-type-method from-alien-form ((type pointer) form) + (declare (ignore type)) + form) + +(define-type-method from-alien-function ((type pointer)) + (declare (ignore type)) + #'identity) + +(define-type-method writer-function ((type pointer)) + (declare (ignore type)) #'(lambda (sap location &optional (offset 0)) (setf (sap-ref-sap location offset) sap))) -(defmethod reader-function ((type (eql 'system-area-pointer)) &rest args) - (declare (ignore type args)) +(define-type-method reader-function ((type pointer)) + (declare (ignore type)) #'(lambda (location &optional (offset 0) weak-p) (declare (ignore weak-p)) (sap-ref-sap location offset))) -(defmethod alien-type ((type (eql 'null)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type null)) + (declare (ignore type)) (alien-type 'pointer)) -(defmethod size-of ((type (eql 'null)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type null)) + (declare (ignore type)) (size-of 'pointer)) -(defmethod to-alien-form (null (type (eql 'null)) &rest args) - (declare (ignore null type args)) +(define-type-method to-alien-form ((type null) null) + (declare (ignore null type)) `(make-pointer 0)) -(defmethod to-alien-function ((type (eql 'null)) &rest args) - (declare (ignore type args)) +(define-type-method to-alien-function ((type null)) + (declare (ignore type)) #'(lambda (null) (declare (ignore null)) (make-pointer 0))) -(defmethod alien-type ((type (eql 'nil)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type nil)) + (declare (ignore type)) 'void) -(defmethod from-alien-function ((type (eql 'nil)) &rest args) - (declare (ignore type args)) +(define-type-method from-alien-function ((type nil)) + (declare (ignore type)) #'(lambda (value) (declare (ignore value)) (values))) - -(defmethod alien-type ((type (eql 'copy-of)) &rest args) +(define-type-method to-alien-form ((type nil) form) (declare (ignore type)) - (alien-type (first args))) + form) -(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))) +(define-type-method to-alien-form ((type copy-of) form) + (copy-to-alien-form (second (type-expand-to 'copy-of type)) form)) -(defmethod to-alien-function ((type (eql 'copy-of)) &rest args) - (declare (ignore type)) - (copy-to-alien-function (first args))) +(define-type-method to-alien-function ((type copy-of)) + (copy-to-alien-function (second (type-expand-to 'copy-of type)))) -(defmethod from-alien-form (form (type (eql 'copy-of)) &rest args) - (declare (ignore type)) - (copy-from-alien-form form (first args))) +(define-type-method from-alien-form ((type copy-of) form) + (copy-from-alien-form (second (type-expand-to 'copy-of type)) form)) -(defmethod from-alien-function ((type (eql 'copy-of)) &rest args) - (declare (ignore type)) - (copy-from-alien-function (first args))) +(define-type-method from-alien-function ((type copy-of)) + (copy-from-alien-function (second (type-expand-to 'copy-of type)))) -(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) +(define-type-method alien-type ((type callback)) (declare (ignore type)) - (writer-function (first args))) - - -(defmethod alien-type ((type (eql 'callback)) &rest args) - (declare (ignore type args)) (alien-type 'pointer)) -#+nil -(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)) +(define-type-method to-alien-form ((type callback) callback) + (declare (ignore type )) `(callback-address ,callback)) - -(defmethod to-alien-function ((type (eql 'callback)) &rest args) - (declare (ignore type args)) - #'callback-address) - -#+nil( -#+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) weak-p) - (declare (ignore weak-p)) - (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)) -) \ No newline at end of file diff --git a/glib/genums.lisp b/glib/genums.lisp index a3c4d90..c1548e0 100644 --- a/glib/genums.lisp +++ b/glib/genums.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: genums.lisp,v 1.18 2006-02-19 22:25:31 espen Exp $ +;; $Id: genums.lisp,v 1.19 2006-02-26 15:30:01 espen Exp $ (in-package "GLIB") @@ -42,54 +42,44 @@ (defun %map-enum (mappings op) (deftype enum (&rest args) `(member ,@(%map-enum args :symbols))) -(defmethod alien-type ((type (eql 'enum)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type enum)) + (declare (ignore type)) (alien-type 'signed)) -(defmethod size-of ((type (eql 'enum)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type enum)) + (declare (ignore type)) (size-of 'signed)) -(defmethod to-alien-form (form (type (eql 'enum)) &rest args) - (declare (ignore type)) +(define-type-method to-alien-form ((type enum) form ) `(case ,form - ,@(%map-enum args :symbol-int) - (t (error 'type-error :datum ,form :expected-type '(enum ,@args))))) - - -(defmethod callback-from-alien-form (form (type (eql 'enum)) &rest args) - (apply #'from-alien-form form type args)) + ,@(%map-enum (rest (type-expand-to 'enum type)) :symbol-int) + (t (error 'type-error :datum ,form :expected-type ',type)))) -(defmethod from-alien-form (form (type (eql 'enum)) &rest args) - (declare (ignore type)) +(define-type-method from-alien-form ((type enum) form) `(case ,form - ,@(%map-enum args :int-quoted-symbol))) + ,@(%map-enum (rest (type-expand-to 'enum type)) :int-quoted-symbol))) -(defmethod to-alien-function ((type (eql 'enum)) &rest args) - (declare (ignore type)) - (let ((mappings (%map-enum args :symbol-int))) +(define-type-method to-alien-function ((type enum)) + (let ((mappings (%map-enum (rest (type-expand-to 'enum type)) :symbol-int))) #'(lambda (enum) (or (second (assoc enum mappings)) - (error 'type-error :datum enum :expected-type (cons 'enum args)))))) + (error 'type-error :datum enum :expected-type type))))) -(defmethod from-alien-function ((type (eql 'enum)) &rest args) - (declare (ignore type)) - (let ((mappings (%map-enum args :int-symbol))) +(define-type-method from-alien-function ((type enum)) + (let ((mappings (%map-enum (rest (type-expand-to 'enum type)) :int-symbol))) #'(lambda (int) (second (assoc int mappings))))) -(defmethod writer-function ((type (eql 'enum)) &rest args) - (declare (ignore type)) +(define-type-method writer-function ((type enum)) (let ((writer (writer-function 'signed)) - (function (apply #'to-alien-function 'enum args))) + (function (to-alien-function (type-expand-to 'enum type)))) #'(lambda (enum location &optional (offset 0)) (funcall writer (funcall function enum) location offset)))) -(defmethod reader-function ((type (eql 'enum)) &rest args) - (declare (ignore type)) +(define-type-method reader-function ((type enum)) (let ((reader (reader-function 'signed)) - (function (apply #'from-alien-function 'enum args))) + (function (from-alien-function (type-expand-to 'enum type)))) #'(lambda (location &optional (offset 0) weak-p) (declare (ignore weak-p)) (funcall function (funcall reader location offset))))) @@ -118,25 +108,25 @@ (defun ,enum-int (enum) (defun ,int-enum (value) (case value ,@(%map-enum args :int-quoted-symbol))) - (defmethod to-alien-form (form (type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method to-alien-form ((type ,name) form) + (declare (ignore type)) (list ',enum-int form)) - (defmethod from-alien-form (form (type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method from-alien-form ((type ,name) form) + (declare (ignore type)) (list ',int-enum form)) - (defmethod to-alien-function ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method to-alien-function ((type ,name)) + (declare (ignore type)) #',enum-int) - (defmethod from-alien-function ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method from-alien-function ((type ,name)) + (declare (ignore type)) #',int-enum) - (defmethod writer-function ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method writer-function ((type ,name)) + (declare (ignore type)) (let ((writer (writer-function 'signed))) #'(lambda (enum location &optional (offset 0)) (funcall writer (,enum-int enum) location offset)))) - (defmethod reader-function ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method reader-function ((type ,name)) + (declare (ignore type)) (let ((reader (reader-function 'signed))) #'(lambda (location &optional (offset 0) weak-p) (declare (ignore weak-p)) @@ -160,63 +150,53 @@ (defun %map-flags (mappings op) (deftype flags (&rest args) `(or (member ,@(%map-flags args :symbols)) list)) -(defmethod alien-type ((type (eql 'flags)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type flags)) + (declare (ignore type)) (alien-type 'unsigned)) -(defmethod size-of ((type (eql 'flags)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type flags)) + (declare (ignore type)) (size-of 'unsigned)) -(defmethod to-alien-form (flags (type (eql 'flags)) &rest args) +(define-type-method to-alien-form ((type flags) flags) `(reduce #'logior (mklist ,flags) :key #'(lambda (flag) (case flag - ,@(%map-flags args :symbol-int) - (t (error 'type-error :datum ,flags - :expected-type '(,type ,@args))))))) + ,@(%map-flags (rest (type-expand-to 'flags type)) :symbol-int) + (t (error 'type-error :datum ,flags :expected-type ',type)))))) -(defmethod callback-from-alien-form (form (type (eql 'flags)) &rest args) - (apply #'from-alien-form form type args)) - -(defmethod from-alien-form (value (type (eql 'flags)) &rest args) - (declare (ignore type)) +(define-type-method from-alien-form ((type flags) value) `(loop - for (int symbol) in ',(%map-flags args :int-symbol) + for (int symbol) in ',(%map-flags (rest (type-expand-to 'flags type)) :int-symbol) when (= (logand ,value int) int) collect symbol)) -(defmethod to-alien-function ((type (eql 'flags)) &rest args) - (declare (ignore type)) - (let ((mappings (%map-flags args :symbol-int))) +(define-type-method to-alien-function ((type flags)) + (let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :symbol-int))) #'(lambda (flags) (reduce #'logior (mklist flags) :key #'(lambda (flag) (or (second (assoc flag mappings)) - (error 'type-error :datum flags - :expected-type (cons 'flags args)))))))) + (error 'type-error :datum flags :expected-type type))))))) -(defmethod from-alien-function ((type (eql 'flags)) &rest args) - (declare (ignore type)) - (let ((mappings (%map-flags args :int-symbol))) +(define-type-method from-alien-function ((type flags)) + (let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :int-symbol))) #'(lambda (value) (loop for (int symbol) in mappings when (= (logand value int) int) collect symbol)))) -(defmethod writer-function ((type (eql 'flags)) &rest args) - (declare (ignore type)) +(define-type-method writer-function ((type flags)) (let ((writer (writer-function 'unsigned)) - (function (apply #'to-alien-function 'flags args))) + (function (to-alien-function (type-expand-to 'flags type)))) #'(lambda (flags location &optional (offset 0)) (funcall writer (funcall function flags) location offset)))) -(defmethod reader-function ((type (eql 'flags)) &rest args) - (declare (ignore type)) +(define-type-method reader-function ((type flags)) (let ((reader (reader-function 'unsigned)) - (function (apply #'from-alien-function 'flags args))) + (function (from-alien-function (type-expand-to 'flags type)))) #'(lambda (location &optional (offset 0) weak-p) (declare (ignore weak-p)) (funcall function (funcall reader location offset))))) @@ -248,31 +228,31 @@ (defun ,int-flags (value) for (int symbol) in ',(%map-flags args :int-symbol) when(= (logand value int) int) collect symbol)) - (defmethod alien-type ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method alien-type ((type ,name)) + (declare (ignore type)) (alien-type 'flags)) - (defmethod size-of ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method size-of ((type ,name)) + (declare (ignore type)) (size-of 'flags)) - (defmethod to-alien-form (form (type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method to-alien-form ((type ,name) form) + (declare (ignore type)) (list ',flags-int form)) - (defmethod from-alien-form (form (type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method from-alien-form ((type ,name) form) + (declare (ignore type)) (list ',int-flags form)) - (defmethod to-alien-function ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method to-alien-function ((type ,name)) + (declare (ignore type)) #',flags-int) - (defmethod from-alien-function ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method from-alien-function ((type ,name)) + (declare (ignore type)) #',int-flags) - (defmethod writer-function ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method writer-function ((type ,name)) + (declare (ignore type)) (let ((writer (writer-function 'signed))) #'(lambda (flags location &optional (offset 0)) - (funcall writer (,flags-int flags) location offset)))) - (defmethod reader-function ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (funcall writer (,flags-int flags) location offset)))) + (define-type-method reader-function ((type ,name)) + (declare (ignore type)) (let ((reader (reader-function 'signed))) #'(lambda (location &optional (offset 0) weak-p) (declare (ignore weak-p)) diff --git a/glib/gerror.lisp b/glib/gerror.lisp index e19063f..5e0f56d 100644 --- a/glib/gerror.lisp +++ b/glib/gerror.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gerror.lisp,v 1.4 2006-02-19 19:31:14 espen Exp $ +;; $Id: gerror.lisp,v 1.5 2006-02-26 15:30:01 espen Exp $ (in-package "GLIB") @@ -67,9 +67,9 @@ (defun signal-gerror (gerror) (deftype gerror-signal () 'gerror) -(defmethod from-alien-form (gerror (type (eql 'gerror-signal)) &rest args) - (declare (ignore type args)) - `(let ((gerror ,(from-alien-form gerror 'gerror))) +(define-type-method from-alien-form ((type gerror-signal) gerror) + (declare (ignore type)) + `(let ((gerror ,(from-alien-form 'gerror gerror))) (when gerror (signal-gerror gerror)))) diff --git a/glib/ginterface.lisp b/glib/ginterface.lisp index 0e89408..a0fde4d 100644 --- a/glib/ginterface.lisp +++ b/glib/ginterface.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: ginterface.lisp,v 1.14 2006-02-15 09:45:41 espen Exp $ +;; $Id: ginterface.lisp,v 1.15 2006-02-26 15:30:01 espen Exp $ (in-package "GLIB") @@ -62,11 +62,12 @@ (defmethod compute-effective-slot-definition-initargs ((class ginterface-class) (defmethod shared-initialize ((class ginterface-class) names &key name gtype) (declare (ignore names)) (let* ((class-name (or name (class-name class))) - (type-number - (or - (find-type-number class-name) - (register-type class-name - (or (first gtype) (default-type-init-name class-name)))))) +;; (type-number +;; (or +;; (find-type-number class-name) +;; (register-type class-name +;; (or (first gtype) (default-type-init-name class-name))))) + ) ; (type-default-interface-ref type-number) ) (call-next-method)) @@ -76,40 +77,40 @@ (defmethod validate-superclass ((class ginterface-class) (super standard-class)) (subtypep (class-name super) 'ginterface)) -(defmethod alien-type ((class ginterface-class) &rest args) - (declare (ignore class args)) +(define-type-method alien-type ((type ginterface)) + (declare (ignore type)) (alien-type 'gobject)) -(defmethod size-of ((class ginterface-class) &rest args) - (declare (ignore class args)) +(define-type-method size-of ((type ginterface)) + (declare (ignore type)) (size-of 'gobject)) -(defmethod from-alien-form (location (class ginterface-class) &rest args) - (declare (ignore class args)) - (from-alien-form location 'gobject)) +(define-type-method from-alien-form ((type ginterface) location) + (declare (ignore type)) + (from-alien-form 'gobject location)) -(defmethod from-alien-function ((class ginterface-class) &rest args) - (declare (ignore class args)) +(define-type-method from-alien-function ((type ginterface)) + (declare (ignore type)) (from-alien-function 'gobject)) -(defmethod to-alien-form (instance (class ginterface-class) &rest args) - (declare (ignore class args)) - (to-alien-form instance 'gobject)) +(define-type-method to-alien-form ((type ginterface) instance) + (declare (ignore type)) + (to-alien-form 'gobject instance)) -(defmethod to-alien-function ((class ginterface-class) &rest args) - (declare (ignore class args)) +(define-type-method to-alien-function ((type ginterface)) + (declare (ignore type)) (to-alien-function 'gobject)) -(defmethod reader-function ((class ginterface-class) &rest args) - (declare (ignore class args)) +(define-type-method reader-function ((type ginterface)) + (declare (ignore type)) (reader-function 'gobject)) -(defmethod writer-function ((class ginterface-class) &rest args) - (declare (ignore class args)) +(define-type-method writer-function ((type ginterface)) + (declare (ignore type)) (writer-function 'gobject)) -(defmethod destroy-function ((class ginterface-class) &rest args) - (declare (ignore class args)) +(define-type-method destroy-function ((type ginterface)) + (declare (ignore type)) (destroy-function 'gobject)) diff --git a/glib/glib.lisp b/glib/glib.lisp index 3909ac8..a5f29ac 100644 --- a/glib/glib.lisp +++ b/glib/glib.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: glib.lisp,v 1.35 2006-02-19 22:34:28 espen Exp $ +;; $Id: glib.lisp,v 1.36 2006-02-26 15:30:01 espen Exp $ (in-package "GLIB") @@ -48,7 +48,7 @@ (defun copy-memory (from length &optional (to (allocate-memory length))) to) (defun clear-memory (from length) - #+cmu(system-area-fill 0 0 from 0 (* 8 length)) + #+cmu(vm::system-area-fill 0 from 0 (* 8 length)) #+sbcl(system-area-ub8-fill 0 from 0 length)) (defmacro with-allocated-memory ((var size) &body body) @@ -128,7 +128,7 @@ (defbinding quark-to-string () (copy-of string) ;;;; Linked list (GList) (deftype glist (type) - `(or (null (cons ,type list)))) + `(or null (cons ,type list))) (defbinding (%glist-append "g_list_append") () pointer (glist pointer) @@ -179,82 +179,71 @@ (defun destroy-glist (glist element-type) do (funcall destroy tmp 0)) (glist-free glist)) -(defmethod alien-type ((type (eql 'glist)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type glist)) + (declare (ignore type)) (alien-type 'pointer)) -(defmethod size-of ((type (eql 'glist)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type glist)) + (declare (ignore type)) (size-of 'pointer)) -(defmethod to-alien-form (list (type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method to-alien-form ((type glist) list) + (let ((element-type (second (type-expand-to 'glist type)))) `(make-glist ',element-type ,list))) -(defmethod to-alien-function ((type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method to-alien-function ((type glist)) + (let ((element-type (second (type-expand-to 'glist type)))) #'(lambda (list) (make-glist element-type list)))) -(defmethod from-alien-form (glist (type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method from-alien-form ((type glist) glist) + (let ((element-type (second (type-expand-to 'glist type)))) `(let ((glist ,glist)) (unwind-protect (map-glist 'list #'identity glist ',element-type) (destroy-glist glist ',element-type))))) -(defmethod from-alien-function ((type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method from-alien-function ((type glist)) + (let ((element-type (second (type-expand-to 'glist type)))) #'(lambda (glist) (unwind-protect (map-glist 'list #'identity glist element-type) (destroy-glist glist element-type))))) -(defmethod copy-from-alien-form (glist (type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method copy-from-alien-form ((type glist) glist) + (let ((element-type (second (type-expand-to 'glist type)))) `(map-glist 'list #'identity ,glist ',element-type))) -(defmethod copy-from-alien-function ((type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method copy-from-alien-function ((type glist)) + (let ((element-type (second (type-expand-to 'glist type)))) #'(lambda (glist) (map-glist 'list #'identity glist element-type)))) -(defmethod cleanup-form (glist (type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method cleanup-form ((type glist) glist) + (let ((element-type (second (type-expand-to 'glist type)))) `(destroy-glist ,glist ',element-type))) -(defmethod cleanup-function ((type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method cleanup-function ((type glist)) + (let ((element-type (second (type-expand-to 'glist type)))) #'(lambda (glist) (destroy-glist glist element-type)))) -(defmethod writer-function ((type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method writer-function ((type glist)) + (let ((element-type (second (type-expand-to 'glist type)))) #'(lambda (list location &optional (offset 0)) (setf (sap-ref-sap location offset) (make-glist element-type list))))) -(defmethod reader-function ((type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method reader-function ((type glist)) + (let ((element-type (second (type-expand-to 'glist type)))) #'(lambda (location &optional (offset 0) weak-p) (declare (ignore weak-p)) (unless (null-pointer-p (sap-ref-sap location offset)) (map-glist 'list #'identity (sap-ref-sap location offset) element-type))))) -(defmethod destroy-function ((type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method destroy-function ((type glist)) + (let ((element-type (second (type-expand-to 'glist type)))) #'(lambda (location &optional (offset 0)) (unless (null-pointer-p (sap-ref-sap location offset)) (destroy-glist (sap-ref-sap location offset) element-type) @@ -264,7 +253,7 @@ (defmethod destroy-function ((type (eql 'glist)) &rest args) ;;;; Single linked list (GSList) -(deftype gslist (type) `(or (null (cons ,type list)))) +(deftype gslist (type) `(or null (cons ,type list))) (defbinding (%gslist-prepend "g_slist_prepend") () pointer (gslist pointer) @@ -289,82 +278,71 @@ (defun destroy-gslist (gslist element-type) do (funcall destroy tmp 0)) (gslist-free gslist)) -(defmethod alien-type ((type (eql 'gslist)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type gslist)) + (declare (ignore type)) (alien-type 'pointer)) -(defmethod size-of ((type (eql 'gslist)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type gslist)) + (declare (ignore type)) (size-of 'pointer)) -(defmethod to-alien-form (list (type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method to-alien-form ((type gslist) list) + (let ((element-type (second (type-expand-to 'gslist type)))) `(make-sglist ',element-type ,list))) -(defmethod to-alien-function ((type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method to-alien-function ((type gslist)) + (let ((element-type (second (type-expand-to 'gslist type)))) #'(lambda (list) (make-gslist element-type list)))) -(defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method from-alien-form ((type gslist) gslist) + (let ((element-type (second (type-expand-to 'gslist type)))) `(let ((gslist ,gslist)) (unwind-protect (map-glist 'list #'identity gslist ',element-type) (destroy-gslist gslist ',element-type))))) -(defmethod from-alien-function ((type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method from-alien-function ((type gslist)) + (let ((element-type (second (type-expand-to 'gslist type)))) #'(lambda (gslist) (unwind-protect (map-glist 'list #'identity gslist element-type) (destroy-gslist gslist element-type))))) -(defmethod copy-from-alien-form (gslist (type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method copy-from-alien-form ((type gslist) gslist) + (let ((element-type (second (type-expand-to 'gslist type)))) `(map-glist 'list #'identity ,gslist ',element-type))) -(defmethod copy-from-alien-function ((type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method copy-from-alien-function ((type gslist)) + (let ((element-type (second (type-expand-to 'gslist type)))) #'(lambda (gslist) (map-glist 'list #'identity gslist element-type)))) -(defmethod cleanup-form (gslist (type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method cleanup-form ((type gslist) gslist) + (let ((element-type (second (type-expand-to 'gslist type)))) `(destroy-gslist ,gslist ',element-type))) -(defmethod cleanup-function ((type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method cleanup-function ((type gslist)) + (let ((element-type (second (type-expand-to 'gslist type)))) #'(lambda (gslist) (destroy-gslist gslist element-type)))) -(defmethod writer-function ((type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method writer-function ((type gslist)) + (let ((element-type (second (type-expand-to 'gslist type)))) #'(lambda (list location &optional (offset 0)) (setf (sap-ref-sap location offset) (make-gslist element-type list))))) -(defmethod reader-function ((type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method reader-function ((type gslist)) + (let ((element-type (second (type-expand-to 'gslist type)))) #'(lambda (location &optional (offset 0) weak-p) (declare (ignore weak-p)) (unless (null-pointer-p (sap-ref-sap location offset)) (map-glist 'list #'identity (sap-ref-sap location offset) element-type))))) -(defmethod destroy-function ((type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method destroy-function ((type gslist)) + (let ((element-type (second (type-expand-to 'gslist type)))) #'(lambda (location &optional (offset 0)) (unless (null-pointer-p (sap-ref-sap location offset)) (destroy-gslist (sap-ref-sap location offset) element-type) @@ -428,17 +406,17 @@ (defun destroy-c-vector (location element-type length) (deallocate-memory location)) -(defmethod alien-type ((type (eql 'vector)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type vector)) + (declare (ignore type)) (alien-type 'pointer)) -(defmethod size-of ((type (eql 'vector)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type vector)) + (declare (ignore type)) (size-of 'pointer)) -(defmethod to-alien-form (vector (type (eql 'vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type &optional (length '*)) args +(define-type-method to-alien-form ((type vector) vector) + (destructuring-bind (element-type &optional (length '*)) + (rest (type-expand-to 'vector type)) (if (eq length '*) `(let* ((vector ,vector) (location (sap+ @@ -451,9 +429,9 @@ (defmethod to-alien-form (vector (type (eql 'vector)) &rest args) location) `(make-c-vector ',element-type ,length ,vector)))) -(defmethod from-alien-form (c-vector (type (eql 'vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type &optional (length '*)) args +(define-type-method from-alien-form ((type vector) c-vector) + (destructuring-bind (element-type &optional (length '*)) + (rest (type-expand-to 'vector type)) (if (eq length '*) (error "Can't use vector of variable size as return type") `(let ((c-vector ,c-vector)) @@ -461,24 +439,24 @@ (defmethod from-alien-form (c-vector (type (eql 'vector)) &rest args) (map-c-vector 'vector #'identity c-vector ',element-type ,length) (destroy-c-vector c-vector ',element-type ,length)))))) -(defmethod copy-from-alien-form (c-vector (type (eql 'vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type &optional (length '*)) args +(define-type-method copy-from-alien-form ((type vector) c-vector) + (destructuring-bind (element-type &optional (length '*)) + (rest (type-expand-to 'vector type)) (if (eq length '*) (error "Can't use vector of variable size as return type") `(map-c-vector 'vector #'identity ,c-vector ',element-type ,length)))) -(defmethod copy-from-alien-function ((type (eql 'vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type &optional (length '*)) args +(define-type-method copy-from-alien-function ((type vector)) + (destructuring-bind (element-type &optional (length '*)) + (rest (type-expand-to 'vector type)) (if (eq length '*) (error "Can't use vector of variable size as return type") #'(lambda (c-vector) (map-c-vector 'vector #'identity c-vector element-type length))))) -(defmethod cleanup-form (location (type (eql 'vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type &optional (length '*)) args +(define-type-method cleanup-form ((type vector) location) + (destructuring-bind (element-type &optional (length '*)) + (rest (type-expand-to 'vector type)) `(let* ((location ,location) (length ,(if (eq length '*) `(sap-ref-32 location ,(- +size-of-int+)) @@ -492,17 +470,26 @@ (defmethod cleanup-form (location (type (eql 'vector)) &rest args) `(sap+ location ,(- +size-of-int+)) 'location))))) -(defmethod writer-function ((type (eql 'vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type &optional (length '*)) args +;; We need these so that we can specify vectors with length given as +;; a non constant in callbacks +(define-type-method callback-from-alien-form ((type vector) form) + (copy-from-alien-form type form)) +(define-type-method callback-cleanup-form ((type vector) form) + (declare (ignore type form)) + nil) + + +(define-type-method writer-function ((type vector)) + (destructuring-bind (element-type &optional (length '*)) + (rest (type-expand-to 'vector type)) #'(lambda (vector location &optional (offset 0)) (setf (sap-ref-sap location offset) (make-c-vector element-type length vector))))) -(defmethod reader-function ((type (eql 'vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type &optional (length '*)) args +(define-type-method reader-function ((type vector)) + (destructuring-bind (element-type &optional (length '*)) + (rest (type-expand-to 'vector type)) (if (eq length '*) (error "Can't create reader function for vector of variable size") #'(lambda (location &optional (offset 0) weak-p) @@ -511,9 +498,9 @@ (defmethod reader-function ((type (eql 'vector)) &rest args) (map-c-vector 'vector #'identity (sap-ref-sap location offset) element-type length)))))) -(defmethod destroy-function ((type (eql 'vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type &optional (length '*)) args +(define-type-method destroy-function ((type vector)) + (destructuring-bind (element-type &optional (length '*)) + (rest (type-expand-to 'vector type)) (if (eq length '*) (error "Can't create destroy function for vector of variable size") #'(lambda (location &optional (offset 0)) @@ -581,40 +568,40 @@ (defun destroy-0-vector (location element-type) (deftype null-terminated-vector (element-type) `(vector ,element-type)) -(defmethod alien-type ((type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type null-terminated-vector)) + (declare (ignore type)) (alien-type 'pointer)) -(defmethod size-of ((type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type null-terminated-vector)) + (declare (ignore type)) (size-of 'pointer)) -(defmethod to-alien-form (vector (type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method to-alien-form ((type null-terminated-vector) vector) + (destructuring-bind (element-type) + (rest (type-expand-to 'null-terminated-vector type)) `(make-0-vector ',element-type ,vector))) -(defmethod from-alien-form (c-vector (type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method from-alien-form ((type null-terminated-vector) c-vector) + (destructuring-bind (element-type) + (rest (type-expand-to 'null-terminated-vector type)) `(let ((c-vector ,c-vector)) (prog1 (map-0-vector 'vector #'identity c-vector ',element-type) (destroy-0-vector c-vector ',element-type))))) -(defmethod copy-from-alien-form (c-vector (type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method copy-from-alien-form ((type null-terminated-vector) c-vector) + (destructuring-bind (element-type) + (rest (type-expand-to 'null-terminated-vector type)) `(map-0-vector 'vector #'identity ,c-vector ',element-type))) -(defmethod cleanup-form (location (type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method cleanup-form ((type null-terminated-vector) location) + (destructuring-bind (element-type) + (rest (type-expand-to 'null-terminated-vector type)) `(destroy-0-vector ,location ',element-type))) -(defmethod writer-function ((type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method writer-function ((type null-terminated-vector)) + (destructuring-bind (element-type) + (rest (type-expand-to 'null-terminated-vector type)) (unless (eq (alien-type element-type) (alien-type 'pointer)) (error "Elements in null-terminated vectors need to be of pointer types")) #'(lambda (vector location &optional (offset 0)) @@ -622,9 +609,9 @@ (defmethod writer-function ((type (eql 'null-terminated-vector)) &rest args) (sap-ref-sap location offset) (make-0-vector element-type vector))))) -(defmethod reader-function ((type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method reader-function ((type null-terminated-vector)) + (destructuring-bind (element-type) + (rest (type-expand-to 'null-terminated-vector type)) (unless (eq (alien-type element-type) (alien-type 'pointer)) (error "Elements in null-terminated vectors need to be of pointer types")) #'(lambda (location &optional (offset 0) weak-p) @@ -633,9 +620,9 @@ (defmethod reader-function ((type (eql 'null-terminated-vector)) &rest args) (map-0-vector 'vector #'identity (sap-ref-sap location offset) element-type))))) -(defmethod destroy-function ((type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method destroy-function ((type null-terminated-vector)) + (destructuring-bind (element-type) + (rest (type-expand-to 'null-terminated-vector type)) (unless (eq (alien-type element-type) (alien-type 'pointer)) (error "Elements in null-terminated vectors need to be of pointer types")) #'(lambda (location &optional (offset 0)) @@ -644,9 +631,11 @@ (defmethod destroy-function ((type (eql 'null-terminated-vector)) &rest args) (sap-ref-sap location offset) element-type) (setf (sap-ref-sap location offset) (make-pointer 0)))))) -(defmethod unbound-value ((type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type args)) - (values t nil)) +(define-type-method unbound-value ((type null-terminated-vector)) + (declare (ignore type)) + nil) + + ;;; Counted vector @@ -677,63 +666,63 @@ (defun destroy-counted-vector (location element-type) (deftype counted-vector (element-type) `(vector ,element-type)) -(defmethod alien-type ((type (eql 'counted-vector)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type counted-vector)) + (declare (ignore type)) (alien-type 'pointer)) -(defmethod size-of ((type (eql 'counted-vector)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type counted-vector)) + (declare (ignore type)) (size-of 'pointer)) -(defmethod to-alien-form (vector (type (eql 'counted-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method to-alien-form ((type counted-vector) vector) + (destructuring-bind (element-type) + (rest (type-expand-to 'counted-vector type)) `(make-counted-vector ',element-type ,vector))) -(defmethod from-alien-form (c-vector (type (eql 'counted-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method from-alien-form ((type counted-vector) c-vector) + (destructuring-bind (element-type) + (rest (type-expand-to 'counted-vector type)) `(let ((c-vector ,c-vector)) (prog1 (map-counted-vector 'vector #'identity c-vector ',element-type) (destroy-counted-vector c-vector ',element-type))))) -(defmethod copy-from-alien-form (c-vector (type (eql 'counted-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method copy-from-alien-form ((type counted-vector) c-vector) + (destructuring-bind (element-type) + (rest (type-expand-to 'counted-vector type)) `(map-counted-vector 'vector #'identity ,c-vector ',element-type))) -(defmethod copy-from-alien-function ((type (eql 'counted-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method copy-from-alien-function ((type counted-vector)) + (destructuring-bind (element-type) + (rest (type-expand-to 'counted-vector type)) #'(lambda (c-vector) (map-counted-vector 'vector #'identity c-vector element-type)))) -(defmethod cleanup-form (location (type (eql 'counted-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method cleanup-form ((type counted-vector) location) + (destructuring-bind (element-type) + (rest (type-expand-to 'counted-vector type)) `(destroy-counted-vector ,location ',element-type))) -(defmethod writer-function ((type (eql 'counted-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method writer-function ((type counted-vector)) + (destructuring-bind (element-type) + (rest (type-expand-to 'counted-vector type)) #'(lambda (vector location &optional (offset 0)) (setf (sap-ref-sap location offset) (make-counted-vector element-type vector))))) -(defmethod reader-function ((type (eql 'counted-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method reader-function ((type counted-vector)) + (destructuring-bind (element-type) + (rest (type-expand-to 'counted-vector type)) #'(lambda (location &optional (offset 0) weak-p) (declare (ignore weak-p)) (unless (null-pointer-p (sap-ref-sap location offset)) (map-counted-vector 'vector #'identity (sap-ref-sap location offset) element-type))))) -(defmethod destroy-function ((type (eql 'counted-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method destroy-function ((type counted-vector)) + (destructuring-bind (element-type) + (rest (type-expand-to 'counted-vector type)) #'(lambda (location &optional (offset 0)) (unless (null-pointer-p (sap-ref-sap location offset)) (destroy-counted-vector diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 59e8fcc..a0631dc 100644 --- a/glib/gobject.lisp +++ b/glib/gobject.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gobject.lisp,v 1.49 2006-02-19 22:24:37 espen Exp $ +;; $Id: gobject.lisp,v 1.50 2006-02-26 15:30:01 espen Exp $ (in-package "GLIB") @@ -66,6 +66,7 @@ (defbinding %object-unref () nil (progn (define-callback toggle-ref-callback nil ((data pointer) (location pointer) (last-ref-p boolean)) + (declare (ignore data)) #+debug-ref-counting (if last-ref-p (format t "Object at 0x~8,'0X has no foreign references~%" (sap-int location)) @@ -215,7 +216,6 @@ (defmethod shared-initialize :after ((class gobject-class) names &rest initargs) (setf (slot-value class 'instance-slots-p) t))) - ;;;; Super class for all classes in the GObject type hierarchy (eval-when (:compile-toplevel :load-toplevel :execute) @@ -225,6 +225,9 @@ (defclass gobject (ginstance) (:metaclass gobject-class) (:gtype "GObject"))) +(define-type-method callback-from-alien-form ((type gobject) form) + (from-alien-form type form)) + #+debug-ref-counting (defmethod print-object ((instance gobject) stream) (print-unreadable-object (instance stream :type t :identity nil) @@ -554,16 +557,17 @@ (register-derivable-type 'gobject "GObject" 'expand-gobject-type 'gobject-depend ;;; Pseudo type for gobject instances which have their reference count ;;; increased by the returning function -(defmethod alien-type ((type (eql 'referenced)) &rest args) - (declare (ignore type args)) - (alien-type 'gobject)) +;; (deftype referenced (type) type) -(defmethod from-alien-form (form (type (eql 'referenced)) &rest args) +(define-type-method alien-type ((type referenced)) (declare (ignore type)) - (destructuring-bind (type) args + (alien-type 'gobject)) + +(define-type-method from-alien-form ((type referenced) form) + (let ((type (second type))) (if (subtypep type 'gobject) (let ((instance (make-symbol "INSTANCE"))) - `(let ((,instance ,(from-alien-form form type))) + `(let ((,instance ,(from-alien-form type form))) (when ,instance (%object-unref (foreign-location ,instance))) ,instance)) diff --git a/glib/gtype.lisp b/glib/gtype.lisp index 866b437..d4a4921 100644 --- a/glib/gtype.lisp +++ b/glib/gtype.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtype.lisp,v 1.46 2006-02-19 22:25:31 espen Exp $ +;; $Id: gtype.lisp,v 1.47 2006-02-26 15:30:01 espen Exp $ (in-package "GLIB") @@ -34,40 +34,40 @@ (deftype type-number () '(unsigned 32)) (deftype gtype () 'symbol) -(defmethod alien-type ((type (eql 'gtype)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type gtype)) + (declare (ignore type)) (alien-type 'type-number)) -(defmethod size-of ((type (eql 'gtype)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type gtype)) + (declare (ignore type)) (size-of 'type-number)) -(defmethod to-alien-form (gtype (type (eql 'gtype)) &rest args) - (declare (ignore type args)) +(define-type-method to-alien-form ((type gtype) gtype) + (declare (ignore type)) `(find-type-number ,gtype t)) -(defmethod to-alien-function ((type (eql 'gtype)) &rest args) - (declare (ignore type args)) +(define-type-method to-alien-function ((type gtype)) + (declare (ignore type)) #'(lambda (gtype) (find-type-number gtype t))) -(defmethod from-alien-form (type-number (type (eql 'gtype)) &rest args) - (declare (ignore type args)) +(define-type-method from-alien-form ((type gtype) type-number) + (declare (ignore type)) `(type-from-number ,type-number)) -(defmethod from-alien-function ((type (eql 'gtype)) &rest args) - (declare (ignore type args)) +(define-type-method from-alien-function ((type gtype)) + (declare (ignore type)) #'(lambda (type-number) (type-from-number type-number))) -(defmethod writer-function ((type (eql 'gtype)) &rest args) - (declare (ignore type args)) +(define-type-method writer-function ((type gtype)) + (declare (ignore type)) (let ((writer (writer-function 'type-number))) #'(lambda (gtype location &optional (offset 0)) (funcall writer (find-type-number gtype t) location offset)))) -(defmethod reader-function ((type (eql 'gtype)) &rest args) - (declare (ignore type args)) +(define-type-method reader-function ((type gtype)) + (declare (ignore type)) (let ((reader (reader-function 'type-number))) #'(lambda (location &optional (offset 0) weak-p) (declare (ignore weak-p)) @@ -317,8 +317,8 @@ (default-alien-type-name class-name))) (when (and (supertype type-number) (not (eq (class-name super) (supertype type-number)))) - (warn "~A is the super type for ~A in the gobject type system." - (supertype type-number) class-name))) + (warn "Super class mismatch between CLOS and GObject for ~A" + class-name))) (update-size class)) @@ -376,23 +376,18 @@ (defmethod invalidate-instance ((instance ginstance)) ;; A ginstance should never be invalidated since it is ref counted nil) -(defmethod callback-from-alien-form (form (class ginstance-class) &rest args) - (declare (ignore args)) - (from-alien-form form class)) - -(defmethod copy-from-alien-form (location (class ginstance-class) &rest args) - (declare (ignore location class args)) +(define-type-method copy-from-alien-form ((type ginstance) location) + (declare (ignore location type)) (error "Doing copy-from-alien on a ref. counted class is most certainly an error, but if it really is what you want you should use REFERENCE-FOREIGN on the returned instance instead.")) -(defmethod copy-from-alien-function ((class ginstance-class) &rest args) - (declare (ignore class args)) +(define-type-method copy-from-alien-function ((type ginstance)) + (declare (ignore type)) (error "Doing copy-from-alien on a ref. counted class is most certainly an error, but if it really is what you want you should use REFERENCE-FOREIGN on the returned instance instead.")) -(defmethod reader-function ((class ginstance-class) &rest args) - (declare (ignore args)) +(define-type-method reader-function ((type ginstance)) #'(lambda (location &optional (offset 0) weak-p) (declare (ignore weak-p)) - (ensure-proxy-instance class (sap-ref-sap location offset)))) + (ensure-proxy-instance type (sap-ref-sap location offset)))) ;;;; Registering fundamental types diff --git a/glib/proxy.lisp b/glib/proxy.lisp index a129855..1ca8fe5 100644 --- a/glib/proxy.lisp +++ b/glib/proxy.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: proxy.lisp,v 1.35 2006-02-19 19:23:23 espen Exp $ +;; $Id: proxy.lisp,v 1.36 2006-02-26 15:30:01 espen Exp $ (in-package "GLIB") @@ -124,11 +124,14 @@ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-def (mkbinding boundp (slot-definition-type slotd) 'pointer))) (funcall reader (foreign-location object)))))))) - ((multiple-value-bind (unbound-p unbound-value) - (unbound-value (slot-definition-type slotd)) - (when unbound-p - #'(lambda (object) - (not (eq (funcall getter-function object) unbound-value)))))) + ((let ((unbound-value-method + (find-applicable-type-method 'unbound-value + (slot-definition-type slotd) nil))) + (when unbound-value-method + (let ((unbound-value + (funcall unbound-value-method (slot-definition-type slotd)))) + #'(lambda (object) + (not (eq (funcall getter-function object) unbound-value))))))) (#'(lambda (object) (declare (ignore object)) t)))) (setf @@ -148,10 +151,13 @@ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-def (and (funcall boundp-function object) (funcall getter-function object))))) - ((multiple-value-bind (unbound-p unbound-value) - (unbound-value (slot-definition-type slotd)) - (let ((slot-name (slot-definition-name slotd))) - (when unbound-p + ((let ((unbound-value-method + (find-applicable-type-method 'unbound-value + (slot-definition-type slotd) nil))) + (when unbound-value-method + (let ((unbound-value + (funcall unbound-value-method (slot-definition-type slotd))) + (slot-name (slot-definition-name slotd))) #'(lambda (object) (let ((value (funcall getter-function object))) (if (eq value unbound-value) @@ -339,7 +345,7 @@ (defmethod print-object ((instance proxy) stream) (print-unreadable-object (instance stream :type t :identity nil) (if (slot-boundp instance 'location) (format stream "at 0x~X" (sap-int (foreign-location instance))) - (write-string "at \"unbound\"" stream)))) + (write-string "at " stream)))) (defmethod initialize-instance :around ((instance proxy) &rest initargs &key &allow-other-keys) (setf @@ -481,75 +487,73 @@ (defmethod foreign-size ((object proxy)) (foreign-size (class-of object))) -(defmethod alien-type ((class proxy-class) &rest args) - (declare (ignore class args)) +(define-type-method alien-type ((class proxy)) + (declare (ignore class)) (alien-type 'pointer)) -(defmethod size-of ((class proxy-class) &rest args) - (declare (ignore class args)) +(define-type-method size-of ((class proxy)) + (declare (ignore class)) (size-of 'pointer)) -(defmethod from-alien-form (location (class proxy-class) &rest args) - (declare (ignore args)) - `(ensure-proxy-instance ',(class-name class) ,location)) +(define-type-method from-alien-form ((type proxy) location) + (let ((class (type-expand type))) + `(ensure-proxy-instance ',class ,location))) -(defmethod from-alien-function ((class proxy-class) &rest args) - (declare (ignore args)) - #'(lambda (location) - (ensure-proxy-instance class location))) +(define-type-method from-alien-function ((type proxy)) + (let ((class (type-expand type))) + #'(lambda (location) + (ensure-proxy-instance class location)))) -(defmethod to-alien-form (instance (class proxy-class) &rest args) - (declare (ignore class args)) +(define-type-method to-alien-form ((type proxy) instance) + (declare (ignore type)) `(foreign-location ,instance)) -(defmethod to-alien-function ((class proxy-class) &rest args) - (declare (ignore class args)) +(define-type-method to-alien-function ((type proxy)) + (declare (ignore type)) #'foreign-location) -(defmethod copy-from-alien-form (location (class proxy-class) &rest args) - (declare (ignore args)) - (let ((class-name (class-name class))) - `(ensure-proxy-instance ',class-name - (reference-foreign ',class-name ,location)))) - -(defmethod copy-from-alien-function ((class proxy-class) &rest args) - (declare (ignore args)) - #'(lambda (location) - (ensure-proxy-instance class (reference-foreign class location)))) - -(defmethod copy-to-alien-form (instance (class proxy-class) &rest args) - (declare (ignore args)) - `(reference-foreign ',(class-name class) (foreign-location ,instance))) - -(defmethod copy-to-alien-function ((class proxy-class) &rest args) - (declare (ignore args)) - #'(lambda (instance) - (reference-foreign class (foreign-location instance)))) - -(defmethod writer-function ((class proxy-class) &rest args) - (declare (ignore args)) - #'(lambda (instance location &optional (offset 0)) - (assert (null-pointer-p (sap-ref-sap location offset))) - (setf - (sap-ref-sap location offset) - (reference-foreign class (foreign-location instance))))) - -(defmethod reader-function ((class proxy-class) &rest args) - (declare (ignore args)) - #'(lambda (location &optional (offset 0) weak-p) - (declare (ignore weak-p)) - (let ((instance (sap-ref-sap location offset))) - (unless (null-pointer-p instance) - (ensure-proxy-instance class (reference-foreign class instance)))))) - -(defmethod destroy-function ((class proxy-class) &rest args) - (declare (ignore args)) - #'(lambda (location &optional (offset 0)) - (unreference-foreign class (sap-ref-sap location offset)))) - -(defmethod unbound-value ((class proxy-class) &rest args) - (declare (ignore args)) - (values t nil)) +(define-type-method copy-from-alien-form ((type proxy) location) + (let ((class (type-expand type))) + `(ensure-proxy-instance ',class (reference-foreign ',class ,location)))) + +(define-type-method copy-from-alien-function ((type proxy)) + (let ((class (type-expand type))) + #'(lambda (location) + (ensure-proxy-instance class (reference-foreign class location))))) + +(define-type-method copy-to-alien-form ((type proxy) instance) + (let ((class (type-expand type))) + `(reference-foreign ',class (foreign-location ,instance)))) + +(define-type-method copy-to-alien-function ((type proxy)) + (let ((class (type-expand type))) + #'(lambda (instance) + (reference-foreign class (foreign-location instance))))) + +(define-type-method writer-function ((type proxy)) + (let ((class (type-expand type))) + #'(lambda (instance location &optional (offset 0)) + (assert (null-pointer-p (sap-ref-sap location offset))) + (setf + (sap-ref-sap location offset) + (reference-foreign class (foreign-location instance)))))) + +(define-type-method reader-function ((type proxy)) + (let ((class (type-expand type))) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) + (let ((instance (sap-ref-sap location offset))) + (unless (null-pointer-p instance) + (ensure-proxy-instance class (reference-foreign class instance))))))) + +(define-type-method destroy-function ((type proxy)) + (let ((class (type-expand type))) + #'(lambda (location &optional (offset 0)) + (unreference-foreign class (sap-ref-sap location offset))))) + +(define-type-method unbound-value ((type proxy)) + (declare (ignore type)) + nil) (defun ensure-proxy-instance (class location &rest initargs) "Returns a proxy object representing the foreign object at the give @@ -603,8 +607,9 @@ (defmethod allocate-foreign ((struct struct) &rest initargs) ;;;; Metaclasses used for subclasses of struct -(defclass struct-class (proxy-class) - ()) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass struct-class (proxy-class) + ())) (defmethod direct-slot-definition-class ((class struct-class) &rest initargs) (if (not (getf initargs :allocation)) @@ -631,14 +636,22 @@ (defmethod compute-slots :around ((class struct-class)) (setf (slot-value class 'size) (+ size (mod size +struct-alignmen+))))) slots)) -(defmethod reader-function ((class struct-class) &rest args) - (declare (ignore args)) - #'(lambda (location &optional (offset 0) weak-p) - (let ((instance (sap-ref-sap location offset))) - (unless (null-pointer-p instance) - (if weak-p - (ensure-proxy-instance class instance :weak t) - (ensure-proxy-instance class (reference-foreign class instance))))))) +(define-type-method callback-from-alien-form ((type struct) form) + (let ((class (type-expand type))) + `(ensure-proxy-instance ',class ,form :weak t))) + +(define-type-method callback-cleanup-form ((type struct) form) + (declare (ignore type)) + `(invalidate-instance ,form)) + +(define-type-method reader-function ((type struct)) + (let ((class (type-expand type))) + #'(lambda (location &optional (offset 0) weak-p) + (let ((instance (sap-ref-sap location offset))) + (unless (null-pointer-p instance) + (if weak-p + (ensure-proxy-instance class instance :weak t) + (ensure-proxy-instance class (reference-foreign class instance)))))))) (defclass static-struct-class (struct-class) @@ -652,45 +665,24 @@ (defmethod unreference-foreign ((class static-struct-class) location) (declare (ignore class location)) nil) -(defmethod reader-function ((class struct-class) &rest args) - (declare (ignore args)) - #'(lambda (location &optional (offset 0) weak-p) - (declare (ignore weak-p)) - (let ((instance (sap-ref-sap location offset))) - (unless (null-pointer-p instance) - (ensure-proxy-instance class instance :weak t))))) - -(defmethod callback-from-alien-form (form (class struct-class) &rest args) - `(ensure-proxy-instance ',(class-name class) ,form :weak t)) - -(defmethod callback-cleanup-form (form (class struct-class) &rest args) - (declare (ignore class)) - `(invalidate-instance ,form)) - - ;;; Pseudo type for structs which are inlined in other objects -(defmethod size-of ((type (eql 'inlined)) &rest args) - (declare (ignore type)) - (foreign-size (first args))) +(deftype inlined (type) type) -(defmethod reader-function ((type (eql 'inlined)) &rest args) - (declare (ignore type)) - (destructuring-bind (class) args +(define-type-method size-of ((type inlined)) + (let ((class (type-expand (second type)))) + (foreign-size class))) + +(define-type-method reader-function ((type inlined)) + (let ((class (type-expand (second type)))) #'(lambda (location &optional (offset 0) weak-p) (declare (ignore weak-p)) (ensure-proxy-instance class (reference-foreign class (sap+ location offset)))))) -(defmethod writer-function ((type (eql 'inlined)) &rest args) - (declare (ignore type)) - (destructuring-bind (class) args +(define-type-method writer-function ((type inlined)) + (let ((class (type-expand (second type)))) #'(lambda (instance location &optional (offset 0)) (copy-memory (foreign-location instance) (foreign-size class) (sap+ location offset))))) -(defmethod destroy-function ((type (eql 'inlined)) &rest args) - (declare (ignore args)) - #'(lambda (location &optional (offset 0)) - (declare (ignore location offset)))) - (export 'inlined) diff --git a/gtk/gtktree.lisp b/gtk/gtktree.lisp index 52ee220..83e970c 100644 --- a/gtk/gtktree.lisp +++ b/gtk/gtktree.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtktree.lisp,v 1.15 2006-02-19 19:31:15 espen Exp $ +;; $Id: gtktree.lisp,v 1.16 2006-02-26 15:30:01 espen Exp $ (in-package "GTK") @@ -221,67 +221,67 @@ (defun %tree-path-to-vector (location) (map-c-vector 'vector #'identity indices 'int depth)))) (eval-when (:compile-toplevel :load-toplevel :execute) - (defmethod alien-type ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) + (define-type-method alien-type ((type tree-path)) + (declare (ignore type)) (alien-type 'pointer)) - (defmethod size-of ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) + (define-type-method size-of ((type tree-path)) + (declare (ignore type)) (size-of 'pointer)) - (defmethod to-alien-form (path (type (eql 'tree-path)) &rest args) - (declare (ignore type args)) + (define-type-method to-alien-form ((type tree-path) path) + (declare (ignore type)) `(%make-tree-path ,path)) - (defmethod from-alien-form (location (type (eql 'tree-path)) &rest args) - (declare (ignore type args)) + (define-type-method from-alien-form ((type tree-path) location) + (declare (ignore type)) `(let ((location ,location)) (prog1 (%tree-path-to-vector location) (%tree-path-free location)))) - (defmethod copy-from-alien-form (location (type (eql 'tree-path)) &rest args) - (declare (ignore type args)) + (define-type-method copy-from-alien-form ((type tree-path) location) + (declare (ignore type)) `(%tree-path-to-vector ,location)) - (defmethod cleanup-form (location (type (eql 'tree-path)) &rest args) - (declare (ignore type args)) + (define-type-method cleanup-form ((type tree-path) location) + (declare (ignore type)) `(%tree-path-free ,location))) -(defmethod to-alien-function ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) +(define-type-method to-alien-function ((type tree-path)) + (declare (ignore type)) #'%make-tree-path) -(defmethod from-alien-function ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) +(define-type-method from-alien-function ((type tree-path)) + (declare (ignore type)) #'(lambda (location) (prog1 (%tree-path-to-vector location) (%tree-path-free location)))) -(defmethod copy-from-alien-function ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) +(define-type-method copy-from-alien-function ((type tree-path)) + (declare (ignore type )) #'%tree-path-to-vector) -(defmethod cleanup-function ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) +(define-type-method cleanup-function ((type tree-path)) + (declare (ignore type)) #'%tree-path-free) -(defmethod writer-function ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) +(define-type-method writer-function ((type tree-path)) + (declare (ignore type)) (let ((writer (writer-function 'pointer))) #'(lambda (path location &optional (offset 0)) (funcall writer (%make-tree-path path) location offset)))) -(defmethod reader-function ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) +(define-type-method reader-function ((type tree-path)) + (declare (ignore type)) (let ((reader (reader-function 'pointer))) #'(lambda (location &optional (offset 0) weak-p) (declare (ignore weak-p)) (%tree-path-to-vector (funcall reader location offset))))) -(defmethod destroy-function ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) +(define-type-method destroy-function ((type tree-path)) + (declare (ignore type)) (let ((reader (reader-function 'pointer))) #'(lambda (location &optional (offset 0)) (%tree-path-free (funcall reader location offset))))) @@ -405,6 +405,7 @@ (defbinding tree-model-rows-reordered () nil (defun column-types (model columns) + (declare (ignore model)) (map 'vector #'(lambda (column) (find-type-number (first (mklist column)))) @@ -762,6 +763,7 @@ (defbinding tree-store-move-after () nil (defmethod initialize-instance ((tree-view tree-view) &rest initargs &key column) + (declare (ignore column)) (call-next-method) (mapc #'(lambda (column) (tree-view-append-column tree-view column)) diff --git a/gtk/gtktypes.lisp b/gtk/gtktypes.lisp index 4478c51..118b95a 100644 --- a/gtk/gtktypes.lisp +++ b/gtk/gtktypes.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtktypes.lisp,v 1.43 2006-02-15 09:47:42 espen Exp $ +;; $Id: gtktypes.lisp,v 1.44 2006-02-26 15:30:01 espen Exp $ (in-package "GTK") @@ -136,8 +136,16 @@ (register-type 'tree-path '|gtk_tree_path_get_type|) (deftype position () '(or int (enum (:start 0) (:end -1) (:first 0) (:last -1)))) -(defmethod reader-function ((type (eql 'position)) &rest args) - (declare (ignore type args)) +(define-type-method from-alien-form ((type position) form) + (declare (ignore type)) + (from-alien-form 'int form)) + +(define-type-method from-alien-function ((type position)) + (declare (ignore type)) + (from-alien-function 'int)) + +(define-type-method reader-function ((type position)) + (declare (ignore type)) (reader-function 'int))