Type method system redesigned

diff --git a/glib/defpackage.lisp b/glib/defpackage.lisp
index e00387bc3746d9c146300eb9b5d17d3af0aa8ff2..34a8bc0d616310f2025e857ddb56b0715c8ac5ba 100644 (file)
--- 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.
 
 ;; 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")
 
 
 ;(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")
   #+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")
   (: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 69e2516de9270f4d61b0f5ecf82e49363208c027..d13113c3f771843a73003a74cb464438e14294b3 100644 (file)
--- 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.
 
 ;; 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
 
 
 ;;; Autogenerating exported symbols


@@ -34,7 +34,7 @@   (defexport defbinding (name &rest args)
        name
       (first name)))
 
        name
       (first name)))
 

-  (defexport def-type-method (name &rest args)
+  (defexport define-type-generic (name &rest args)

     (declare (ignore args))
     name)
 
     (declare (ignore args))
     name)
 

diff --git a/glib/ffi.lisp b/glib/ffi.lisp
index 7b0c130ef47f9e3660810748073e365eb3a0266c..2f09bbfe64756f6fc2750111787e57c64e030218 100644 (file)
--- 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.
 
 ;; 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")
 
 
 (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)))
                           ((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))
       
       (%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))
     (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))
 
          (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 
             (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))))))
                   ((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
            ((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)
             (alien-parameters var)

-            (return-values (from-alien-form var type)))
+            (return-values (from-alien-form type var)))

            (cleanup
             (alien-types declaration)
             (alien-bindings
            (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 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))))
 
     (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 
           ,(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
                    ,@(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)))
         ((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
                     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)
 
 (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.")
   "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)
 
 
 ;; 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 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)
 
   nil)
 

-(defmethod cleanup-function ((type t) &rest args)
-  (declare (ignore type args))
+(define-type-method cleanup-function ((type t))
+  (declare (ignore type))

   #'identity)
 
   #'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)
 
   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))))
 
   #'(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))
   (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))))
 
     (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+))))
 
     (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))
     (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)))))))
   
        (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) 
     (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)))))))
 
                (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 
     (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))))
 
       (#.+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))
     (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)))))))
       
        (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)
     (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)))))))
        (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)
 
   #+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+)
 
   +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))
 
   `(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)))
 
   #'(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))))
 
   #'(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)))
 
 
   #'(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)
 
   #+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+)
 
   +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))
 
   `(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)))
 
   #'(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))))
 
   #'(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)))
 
 
   #'(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)
 
   #+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)
 
   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))))
 
   #'(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))))
 
 
   #'(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))
 
   (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))
 
   (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
   `(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)))))
   
      (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
   #'(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)))))
 
       (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
   `(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)))))
 
          #+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
   #'(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)))))
 
            #+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))))
 
   `(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))))
 
   #'(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))))
 
   `(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))))
 
   #'(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)
   #'(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))))))
 
        (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)))))
 
   #'(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)))))
 
   #'(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))
 
   (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))
 
   (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)))))
 
   (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)))))
 
   (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))
 
   (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))))
 
   (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))
   (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))))))
 
        (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))
 
   (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))
 
 
   (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))
 
   `(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)))
 
   #'(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)))
 
   `(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))))
 
   #'(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)))
     (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))
 
     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))
   `(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
     #'(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))
         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)
 
   '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+)
 
   +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)))
 
   #'(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)))
 
 
   #'(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))
 
   (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))
 
   (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))
 
   `(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)))
 
 
   #'(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)
 
   '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)))
 
   #'(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))
   (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))
   (declare (ignore type))

-  (writer-function (first args)))
-
-
-(defmethod alien-type ((type (eql 'callback)) &rest args)
-  (declare (ignore type args))

   (alien-type 'pointer))
 
   (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))
   `(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 6624332573c4cf01d0f5ac41a54476cee20d6058..d8fc4a090c6457181ce42fb9e843503cc618c798 100644 (file)
--- 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.
 
 ;; 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")
   
 
 (in-package "GLIB")
   


@@ -42,54 +42,44 @@ (defun %map-enum (mappings op)
 (deftype enum (&rest args)
   `(member ,@(%map-enum args :symbols)))
 
 (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))
 
   (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))
 
   (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
   `(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
   `(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))
     #'(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)))))
 
     #'(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))
   (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))))
     
     #'(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))
   (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)))))
     #'(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)))
        (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))
         (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))
         (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)
         #',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)
         #',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))))    
         (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))
         (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))
 
 (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))
 
   (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))
 
   (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
   `(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
   `(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))
 
     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))
     #'(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))))
 
     #'(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))
   (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))))
     
     #'(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))
   (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)))))
     #'(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))
          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))
         (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))
         (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))
         (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))
         (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)
         #',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)
         #',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))
         (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))
         (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 05bf4b56672b109eb97c4e95f90d77af5102192f..3b06f22e233d6478071f469ccd24119894c934c4 100644 (file)
--- 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.
 
 ;; 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")
 
 
 (in-package "GLIB")


@@ -67,9 +67,9 @@ (defun signal-gerror (gerror)
 
 (deftype gerror-signal () '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))))
 
      (when gerror
        (signal-gerror gerror))))
 

diff --git a/glib/ginterface.lisp b/glib/ginterface.lisp
index ee9b18be51538703f230edf8aed15bb06f6b80f4..fc48e228a29f847ceb0cab89fa924496ba738e96 100644 (file)
--- 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.
 
 ;; 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")
 
 
 (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)))
 (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))
 ;    (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))
 
 
   (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))
 
   (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))
 
   (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))
 
   (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))
 
   (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))
 
   (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))
 
   (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))
 
 
   (destroy-function 'gobject))
 
 

diff --git a/glib/glib.lisp b/glib/glib.lisp
index 8bbda64bf2090c7703f0bd8077813b42c6623203..c67e11bc8e0e1e1ed0a7e137638e359da1f40c53 100644 (file)
--- 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.
 
 ;; 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")
 
 
 (in-package "GLIB")


@@ -48,7 +48,7 @@ (defun copy-memory (from length &optional (to (allocate-memory length)))
   to)
 
 (defun clear-memory (from 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)
   #+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) 
 ;;;; 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)
 
 (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))
 
    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))
 
   (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))
 
   (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)))
 
     `(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))))
 
     #'(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)))))
 
     `(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)))))
 
     #'(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)))
 
     `(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))))
 
     #'(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)))
 
     `(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))))
 
     #'(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)))))
 
     #'(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)))))
 
     #'(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)
     #'(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)
 
 
 ;;;; 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)
 
 (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))
 
    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))
 
   (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))
 
   (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)))
 
     `(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))))
 
     #'(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)))))
 
     `(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)))))
 
     #'(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)))
 
     `(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))))
 
     #'(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)))
 
     `(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))))
 
     #'(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)))))
 
     #'(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)))))
 
     #'(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)
     #'(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))
 
 
   (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))
 
   (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))
 
   (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+
     (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))))
 
          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))
     (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))))))
 
            (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))))
 
     (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)))))
 
     (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+))
     `(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)))))
 
                              `(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)))))
 
     #'(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)
     (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))))))
 
            (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))
     (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))
 
 
 (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))
 
   (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))
 
   (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)))
 
     `(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)))))
 
     `(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)))
 
     `(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)))
 
     `(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))
     (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)))))
 
         (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)
     (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)))))
 
          (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))
     (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))))))
 
             (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
 
 
 ;;; Counted vector


@@ -677,63 +666,63 @@ (defun destroy-counted-vector (location element-type)
 
 (deftype counted-vector (element-type) `(vector ,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))
 
   (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))
 
   (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)))
 
     `(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)))))
 
     `(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)))
 
     `(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))))
 
     #'(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)))
 
     `(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)))))
 
     #'(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)))))
 
     #'(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 
     #'(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 267543ae906912abef5bb4e5a798f79ffabb4689..facb3864d3e7cb2afab9cb7e69a4ce8f41f8c8e5 100644 (file)
--- 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.
 
 ;; 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")
 
 
 (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))
 (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))
     #+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)))
 
 
     (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)
 ;;;; 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")))
 
     (: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)
 #+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
 
 ;;; 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))
   (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")))
     (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))
             (when ,instance
               (%object-unref (foreign-location ,instance)))
             ,instance))

diff --git a/glib/gtype.lisp b/glib/gtype.lisp
index c83c4951ba65565762ff1e8b045dc113facb7827..6b7a3b1844d41b5dce8d412c2cdfa6171f68fbcf 100644 (file)
--- 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.
 
 ;; 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")
 
 
 (in-package "GLIB")
 


@@ -34,40 +34,40 @@ (deftype type-number () '(unsigned 32))
 
 (deftype gtype () 'symbol)
 
 
 (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))
 
   (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))
 
   (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)) 
 
   `(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)))
 
   #'(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)) 
 
   `(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)))
 
   #'(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))))
 
   (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))
   (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))))
     (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))
 
   
   (update-size class))
 


@@ -376,23 +376,18 @@ (defmethod invalidate-instance ((instance ginstance))
   ;; A ginstance should never be invalidated since it is ref counted
   nil)
 
   ;; 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."))
 
   (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."))
 
   (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))
   #'(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
 
 
 ;;;; Registering fundamental types

diff --git a/glib/proxy.lisp b/glib/proxy.lisp
index a114325ca5e09685150229a03f5b3e1dcf6563e7..6177bf1af324d5c5a16613fe185775800928a86d 100644 (file)
--- 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.
 
 ;; 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")
 
 
 (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))))))))
                              (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
        (#'(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)))))
               (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)
               #'(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)))
   (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 <unbound>" stream))))

 
 (defmethod initialize-instance :around ((instance proxy) &rest initargs &key &allow-other-keys) 
   (setf  
 
 (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)))
   
 
   (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))
 
   (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))
 
   (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))
 
   `(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)
 
   #'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
 
 (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
 
 
 ;;;; 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))
 
 (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))
 
          (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)
 
 
 (defclass static-struct-class (struct-class)


@@ -652,45 +665,24 @@ (defmethod unreference-foreign ((class static-struct-class) location)
   (declare (ignore class location))
   nil)
 
   (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
 
 ;;; 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))))))
 
     #'(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)))))
 
     #'(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)
 (export 'inlined)

diff --git a/gtk/gtktree.lisp b/gtk/gtktree.lisp
index 4ef537ef16fbacca9d5303d56f92fb4f68426dcc..0790bf3595cb87751446e6d5a5e6af550344f3db 100644 (file)
--- 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.
 
 ;; 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")
 
 
 (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)
       (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))
   
     (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))
   
     (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))
   
     `(%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))))
   
     `(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))
   
     `(%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)))
 
     `(%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)
   
   #'%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))))
 
   #'(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)
   
   #'%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)
 
   #'%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))))
 
   (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)))))
 
   (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)))))
   (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)
 
 
 (defun column-types (model columns)

+  (declare (ignore model))

   (map 'vector 
        #'(lambda (column)
           (find-type-number (first (mklist column))))
   (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)
 
 (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))
   (call-next-method)
   (mapc #'(lambda (column)
            (tree-view-append-column tree-view column))

diff --git a/gtk/gtktypes.lisp b/gtk/gtktypes.lisp
index 5d407319b6fe7c3b408daf15d3cc1eec3f34502d..b7b6fb79b66f3f9e13f2a96671c3e77099bd19a6 100644 (file)
--- 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.
 
 ;; 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")
 
 
 (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))))
 
 (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))
 
 
   (reader-function 'int))