Made it possible to use regular symbols in enum and flags definitions

[clg] / glib / genums.lisp

diff --git a/glib/genums.lisp b/glib/genums.lisp
index 44278b3cc64a4ebaf79274f8fae7c6a4939589c9..428a486591287349af202b0027a522d3fc10002a 100644 (file)
--- a/glib/genums.lisp
+++ b/glib/genums.lisp
@@ -15,46 +15,25 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 

-;; $Id: genums.lisp,v 1.7 2005-02-03 22:59:35 espen Exp $
+;; $Id: genums.lisp,v 1.10 2005-02-14 00:43:43 espen Exp $

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

-
-
-(defun %map-enum (args op)
-  (let ((current-value 0))
-    (mapcar
-     #'(lambda (mapping)
-        (destructuring-bind (symbol &optional (value current-value))
-            (mklist mapping)
-          (setf current-value (1+ value))
-          (case op
-            (:enum-int (list symbol value))
-            (:flags-int (list symbol value))
-            (:int-enum (list value symbol))
-            (:int-flags (list value symbol))
-            (:symbols symbol))))
-     args)))
-
-(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)
-         (size (proxy-instance-size (find-class class)))
-         (proxy (make-instance class :location sap)))
-      (dotimes (i length)
-       (with-slots (location nickname value) proxy
-         (setf location sap)
-         (setq sap (sap+ sap size))
-         (push
-          (list
-           (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
-           value)
-          values)))
-      values)))
-   

   
 ;;;; Generic enum type
 
   
 ;;;; Generic enum type
 

+(defun %map-enum (mappings op)
+  (loop
+   as value = 1 then (1+ value)
+   for mapping in mappings
+   collect (let ((symbol (if (atom mapping) mapping (first mapping))))
+            (unless (atom mapping)
+              (setq value (second mapping)))
+            (ecase op
+              (:symbol-int `(,symbol ,value))
+              (:int-symbol `(,value ,symbol))
+              (:int-quoted-symbol `(,value ',symbol))
+              (:symbols symbol)))))
+

 (deftype enum (&rest args)
   `(member ,@(%map-enum args :symbols)))
 
 (deftype enum (&rest args)
   `(member ,@(%map-enum args :symbols)))
 


@@ -68,24 +47,27 @@ (defmethod size-of ((type (eql 'enum)) &rest args)
 
 (defmethod to-alien-form (form (type (eql 'enum)) &rest args)
   (declare (ignore type))
 
 (defmethod to-alien-form (form (type (eql 'enum)) &rest args)
   (declare (ignore type))

-  `(ecase ,form
-    ,@(%map-enum args :enum-int)))
+  `(case ,form
+    ,@(%map-enum args :symbol-int)
+    (t (error 'type-error :datum ,form :expected-type '(enum ,@args)))))
+

 
 (defmethod from-alien-form (form (type (eql 'enum)) &rest args)
   (declare (ignore type))
 
 (defmethod from-alien-form (form (type (eql 'enum)) &rest args)
   (declare (ignore type))

-  `(ecase ,form
-    ,@(%map-enum args :int-enum)))
+  `(case ,form
+    ,@(%map-enum args :int-quoted-symbol)))

 
 (defmethod to-alien-function ((type (eql 'enum)) &rest args)
 
 (defmethod to-alien-function ((type (eql 'enum)) &rest args)

-  (let ((mappings (%map-enum args :enum-int)))
+  (declare (ignore type))
+  (let ((mappings (%map-enum args :symbol-int)))

     #'(lambda (enum)
        (or
         (second (assoc enum mappings))
     #'(lambda (enum)
        (or
         (second (assoc enum mappings))

-        (error "~S is not of type ~S" enum (cons type args))))))
+        (error 'type-error :datum enum :expected-type (cons 'enum args))))))

 
 (defmethod from-alien-function ((type (eql 'enum)) &rest args)
   (declare (ignore type))
 
 (defmethod from-alien-function ((type (eql 'enum)) &rest args)
   (declare (ignore type))

-  (let ((mappings (%map-enum args :int-enum)))
+  (let ((mappings (%map-enum args :int-symbol)))

     #'(lambda (int)
        (second (assoc int mappings)))))
 
     #'(lambda (int)
        (second (assoc int mappings)))))
 


@@ -103,21 +85,6 @@ (defmethod reader-function ((type (eql 'enum)) &rest args)
     #'(lambda (location &optional (offset 0))
        (funcall function (funcall reader location offset)))))
 
     #'(lambda (location &optional (offset 0))
        (funcall function (funcall reader location offset)))))
 

-
-
-(defclass %enum-value (struct)
-  ((value :allocation :alien :type int)
-   (name :allocation :alien :type string)
-   (nickname :allocation :alien :type string))
-  (:metaclass static-struct-class))
-
-(defbinding %enum-class-values () pointer
-  (class pointer)
-  (n-values unsigned-int :out))
-
-(defun query-enum-values (type)
-  (%query-enum-or-flags-values #'%enum-class-values '%enum-value type))
-

 (defun enum-int (enum type)
   (funcall (to-alien-function type) enum))
 
 (defun enum-int (enum type)
   (funcall (to-alien-function type) enum))
 


@@ -127,10 +94,61 @@ (defun int-enum (int type)
 (defun enum-mapping (type)
   (rest (type-expand-to 'enum type)))
 
 (defun enum-mapping (type)
   (rest (type-expand-to 'enum type)))
 

+
+;;;; Named enum types
+
+(defmacro define-enum-type (name &rest args)
+  (let ((enum-int (intern (format nil "~A-TO-INT" name)))
+       (int-enum (intern (format nil "INT-TO-~A" name))))
+    `(progn
+       (deftype ,name () '(enum ,@args))
+       (defun ,enum-int (enum)
+        (case enum
+          ,@(%map-enum args :symbol-int)
+          (t (error 'type-error :datum enum :expected-type ',name))))
+       (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))
+        (list ',enum-int form))
+       (defmethod from-alien-form (form (type (eql ',name)) &rest args)
+        (declare (ignore type args))
+        (list ',int-enum form))
+       (defmethod to-alien-function ((type (eql ',name)) &rest args)
+        (declare (ignore type args))
+        #',enum-int)
+       (defmethod from-alien-function ((type (eql ',name)) &rest args)
+        (declare (ignore type args))
+        #',int-enum)
+       (defmethod writer-function ((type (eql ',name)) &rest args)
+        (declare (ignore type args))
+        (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))
+        (let ((reader (reader-function 'signed)))
+          #'(lambda (location &optional (offset 0))
+              (,int-enum (funcall reader location offset))))))))
+
+

 ;;;;  Generic flags type
 
 ;;;;  Generic flags type
 

+(defun %map-flags (mappings op)
+  (loop
+   as value = 1 then (ash value 1)
+   for mapping in mappings
+   collect (let ((symbol (if (atom mapping) mapping (first mapping))))
+            (unless (atom mapping)
+              (setq value (second mapping)))
+            (ecase op
+              (:symbol-int `(,symbol ,value))
+              (:int-symbol `(,value ,symbol))
+              (:symbols symbol)))))
+

 (deftype flags (&rest args)
 (deftype flags (&rest args)

-  `(or null (cons (member ,@(%map-enum args :symbols)) list)))
+  `(or (member ,@(%map-flags args :symbols)) list))

 
 (defmethod alien-type ((type (eql 'flags)) &rest args)
   (declare (ignore type args))
 
 (defmethod alien-type ((type (eql 'flags)) &rest args)
   (declare (ignore type args))


@@ -141,39 +159,34 @@ (defmethod size-of ((type (eql 'flags)) &rest args)
   (size-of 'unsigned))
 
 (defmethod to-alien-form (flags (type (eql 'flags)) &rest args)
   (size-of 'unsigned))
 
 (defmethod to-alien-form (flags (type (eql 'flags)) &rest args)

-  `(loop
-    with value = 0
-    with flags = ,flags
-    for flag in (mklist flags)
-    do (let ((flagval
-             (or
-              (second (assoc flag ',(%map-enum args :flags-int)))
-              (error "~S is not of type ~S" flags '(,type ,@args)))))
-        (setq value (logior value flagval)))
-    finally (return value)))
+  `(reduce #'logior (mklist ,flags)
+    :key #'(lambda (flag)
+            (case flag
+              ,@(%map-flags args :symbol-int)
+              (t (error 'type-error :datum ,flags 
+                  :expected-type '(,type ,@args)))))))

 
 (defmethod from-alien-form (int (type (eql 'flags)) &rest args)
   (declare (ignore type))
   `(loop
 
 (defmethod from-alien-form (int (type (eql 'flags)) &rest args)
   (declare (ignore type))
   `(loop

-    for mapping in ',(%map-enum args :int-flags)
+    for mapping in ',(%map-flags args :int-symbol)

     unless (zerop (logand ,int (first mapping)))
     collect (second mapping)))
 
 (defmethod to-alien-function ((type (eql 'flags)) &rest args)
     unless (zerop (logand ,int (first mapping)))
     collect (second mapping)))
 
 (defmethod to-alien-function ((type (eql 'flags)) &rest args)

-  (let ((mappings (%map-enum args :flags-int)))
-    #'(lambda (flags)  
-       (loop
-        with value = 0
-        for flag in (mklist flags)
-        do (let ((flagval (or
-                   (second (assoc flag mappings))
-                   (error "~S is not of type ~S" flags (cons type args)))))
-             (setq value (logior value flagval)))
-        finally (return value)))))
+  (declare (ignore type))
+  (let ((mappings (%map-flags args :symbol-int)))
+    #'(lambda (flags)
+       (reduce #'logior (mklist flags)
+        :key #'(lambda (flag)
+                 (or
+                  (second (assoc flag mappings))
+                  (error 'type-error :datum flags 
+                   :expected-type (cons 'flags args))))))))

 
 (defmethod from-alien-function ((type (eql 'flags)) &rest args)
   (declare (ignore type))
 
 (defmethod from-alien-function ((type (eql 'flags)) &rest args)
   (declare (ignore type))

-  (let ((mappings (%map-enum args :int-flags)))
+  (let ((mappings (%map-flags args :int-symbol)))

     #'(lambda (int)
        (loop
         for mapping in mappings
     #'(lambda (int)
        (loop
         for mapping in mappings


@@ -195,6 +208,96 @@ (defmethod reader-function ((type (eql 'flags)) &rest args)
        (funcall function (funcall reader location offset)))))
 
 
        (funcall function (funcall reader location offset)))))
 
 

+;;;; Named flags types
+
+(defmacro define-flags-type (name &rest args)
+  (let ((flags-int (intern (format nil "~A-TO-INT" name)))
+       (int-flags (intern (format nil "INT-TO-~A" name)))
+       (satisfies  (intern (format nil "~A-P" name))))
+    `(progn
+       (deftype ,name () '(satisfies ,satisfies))
+       (defun ,satisfies (object)
+        (flet ((valid-p (ob)
+                 (find ob ',(%map-flags args :symbols))))
+          (typecase object
+            (symbol (valid-p object))
+            (list (every #'valid-p object)))))
+       (defun ,flags-int (flags)
+        (reduce #'logior (mklist flags)
+         :key #'(lambda (flag)
+                  (case flag
+                    ,@(%map-flags args :symbol-int)
+                    (t (error 'type-error :datum flags 
+                        :expected-type ',name))))))
+       (defun ,int-flags (value)
+        (loop
+         for mapping in ',(%map-flags args :int-symbol)
+         unless (zerop (logand value (first mapping)))
+         collect (second mapping)))
+       (defmethod alien-type ((type (eql ',name)) &rest args)
+        (declare (ignore type args))
+        (alien-type 'flags))
+       (defmethod size-of ((type (eql ',name)) &rest args)
+        (declare (ignore type args))
+        (size-of 'flags))
+       (defmethod to-alien-form (form (type (eql ',name)) &rest args)
+        (declare (ignore type args))
+        (list ',flags-int form))
+       (defmethod from-alien-form (form (type (eql ',name)) &rest args)
+        (declare (ignore type args))
+        (list ',int-flags form))
+       (defmethod to-alien-function ((type (eql ',name)) &rest args)
+        (declare (ignore type args))
+        #',flags-int)
+       (defmethod from-alien-function ((type (eql ',name)) &rest args)
+        (declare (ignore type args))
+        #',int-flags)
+       (defmethod writer-function ((type (eql ',name)) &rest args)
+        (declare (ignore type args))
+        (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))
+        (let ((reader (reader-function 'signed)))
+          #'(lambda (location &optional (offset 0))
+              (,int-flags (funcall reader location offset))))))))
+
+
+
+;;;; Type definition by introspection
+
+(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)
+         (size (proxy-instance-size (find-class class)))
+         (proxy (make-instance class :location sap)))
+      (dotimes (i length)
+       (with-slots (location nickname value) proxy
+         (setf location sap)
+         (setq sap (sap+ sap size))
+         (push
+          (list
+           (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
+           value)
+          values)))
+      values)))
+
+
+(defclass %enum-value (struct)
+  ((value :allocation :alien :type int)
+   (name :allocation :alien :type string)
+   (nickname :allocation :alien :type string))
+  (:metaclass static-struct-class))
+
+(defbinding %enum-class-values () pointer
+  (class pointer)
+  (n-values unsigned-int :out))
+
+(defun query-enum-values (type)
+  (%query-enum-or-flags-values #'%enum-class-values '%enum-value type))
+

 
 (defclass %flags-value (struct)
   ((value :allocation :alien :type unsigned-int)
 
 (defclass %flags-value (struct)
   ((value :allocation :alien :type unsigned-int)


@@ -210,9 +313,6 @@ (defun query-flags-values (type)
   (%query-enum-or-flags-values #'%flags-class-values '%flags-value type))
 
 
   (%query-enum-or-flags-values #'%flags-class-values '%flags-value type))
 
 

-
-;;;;
-

 (defun expand-enum-type (type-number forward-p options)
   (declare (ignore forward-p))
   (let* ((super (supertype type-number))
 (defun expand-enum-type (type-number forward-p options)
   (declare (ignore forward-p))
   (let* ((super (supertype type-number))


@@ -232,7 +332,9 @@ (defun expand-enum-type (type-number forward-p options)
            #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
     `(progn
        (register-type ',type ,(find-type-name type-number))
            #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
     `(progn
        (register-type ',type ,(find-type-name type-number))

-       (deftype ,type () '(,super ,@expanded-mappings)))))
+       ,(ecase super
+         (enum `(define-enum-type ,type ,@expanded-mappings))
+         (flags `(define-flags-type ,type ,@expanded-mappings))))))

 
 
 (register-derivable-type 'enum "GEnum" 'expand-enum-type)
 
 
 (register-derivable-type 'enum "GEnum" 'expand-enum-type)