Type method system redesigned

diff --git a/glib/defpackage.lisp b/glib/defpackage.lisp
index 5512823bf1770be114f344fcf4b4b9d8d1fcb35d..e10162199f2a0a91bf3deaf481c3d747f2896b57 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 8ac31bb556ac5e2e653ba9130efac737dbedda5c..d88149e98d7a633bbe502cabf6957593eb4b691d 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 2d2474290bda700c361f52ab54eab92d4e4afab5..6be62980a9e8d0e6b97f8a09dc5a6acdee4999f1 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 a3c4d9071256eaf5a9940f8a076dda299f6876a2..c1548e05d17f38f7056ba44287475f64c12f24bc 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 e19063f84d4c0561502b208ae378653d0ed359c3..5e0f56d529d05785d22d2211250341165c9d39af 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 0e89408327f2e669102e4f7a4288c898d498b1f9..a0fde4d592548a6369d5f2f0de4df6946eacf7dc 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 3909ac8581bb7976f643e1e6aaae23bff0e83c9a..a5f29ac438623fc5ed90be34e21d553b6b8d5b92 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 59e8fcc63d850cd4338e2a2dabbdba120b55f320..a0631dc8bff8b0d6a2a5eebe21c4c7d97776de89 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 866b437c685a059d897df84a31e57729d613ff3f..d4a49213a32cc40462809171de766a018084bf1f 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 a12985529d4badd8c2550eb497873a126843439f..1ca8fe5acaa9d4e7c17ce181833fef83fb7714e1 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 52ee220ae6d3acc98d6c6c680ab76cb983d2d51f..83e970c183f8692f8250ac4dfc17136df704e9c8 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 4478c511eace1374eae26ea440f2ac24bce22a62..118b95ada44ab315d40301f701c8d8fa3e025340 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))