64-bit fix

[clg] / glib / genums.lisp

diff --git a/glib/genums.lisp b/glib/genums.lisp
index 64dbc0e606ae5a78fb489fef5189427aafbcdbc6..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.14 2005-04-24 13:24:41 espen Exp $
+;; $Id: genums.lisp,v 1.19 2006-02-26 15:30:01 espen Exp $

 
 (in-package "GLIB")
   
 
 (in-package "GLIB")
   


@@ -42,52 +42,46 @@ (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)))))
-
+    ,@(%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)))
-    #'(lambda (location &optional (offset 0))
+       (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)))))
 
 (defun enum-int (enum type)
        (funcall function (funcall reader location offset)))))
 
 (defun enum-int (enum type)


@@ -114,27 +108,28 @@        (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)))
         (let ((reader (reader-function 'signed)))

-          #'(lambda (location &optional (offset 0))
+          #'(lambda (location &optional (offset 0) weak-p)
+              (declare (ignore weak-p))

               (,int-enum (funcall reader location offset))))))))
 
 
               (,int-enum (funcall reader location offset))))))))
 
 


@@ -155,61 +150,55 @@ (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 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)))
-    #'(lambda (location &optional (offset 0))
+       (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)))))
 
 
        (funcall function (funcall reader location offset)))))
 
 


@@ -239,33 +228,34 @@        (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)))
         (let ((reader (reader-function 'signed)))

-          #'(lambda (location &optional (offset 0))
+          #'(lambda (location &optional (offset 0) weak-p)
+              (declare (ignore weak-p))

               (,int-flags (funcall reader location offset))))))))
 
 
               (,int-flags (funcall reader location offset))))))))
 
 


@@ -276,8 +266,8 @@ (defun %query-enum-or-flags-values (query-function class type)
   (multiple-value-bind (sap length)
       (funcall query-function (type-class-ref type))
     (let ((values nil)
   (multiple-value-bind (sap length)
       (funcall query-function (type-class-ref type))
     (let ((values nil)

-         (size (proxy-instance-size (find-class class)))
-         (proxy (make-instance class :location sap)))
+         (size (foreign-size (find-class class)))
+         (proxy (ensure-proxy-instance class sap)))

       (dotimes (i length)
        (with-slots (location nickname value) proxy
          (setf location sap)
       (dotimes (i length)
        (with-slots (location nickname value) proxy
          (setf location sap)