chiark - git - mdw - clg/blob - glib/genums.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2000-2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: genums.lisp,v 1.15 2006-02-04 12:15:32 espen Exp $
  24
  25 (in-package "GLIB")
  26
  27 ;;;; Generic enum type
  28
  29 (defun %map-enum (mappings op)
  30   (loop
  31    as value = 0 then (1+ value)
  32    for mapping in mappings
  33    collect (let ((symbol (if (atom mapping) mapping (first mapping))))
  34              (unless (atom mapping)
  35                (setq value (second mapping)))
  36              (ecase op
  37                (:symbol-int `(,symbol ,value))
  38                (:int-symbol `(,value ,symbol))
  39                (:int-quoted-symbol `(,value ',symbol))
  40                (:symbols symbol)))))
  41
  42 (deftype enum (&rest args)
  43   `(member ,@(%map-enum args :symbols)))
  44
  45 (defmethod alien-type ((type (eql 'enum)) &rest args)
  46   (declare (ignore type args))
  47   (alien-type 'signed))
  48
  49 (defmethod size-of ((type (eql 'enum)) &rest args)
  50   (declare (ignore type args))
  51   (size-of 'signed))
  52
  53 (defmethod to-alien-form (form (type (eql 'enum)) &rest args)
  54   (declare (ignore type))
  55   `(case ,form
  56     ,@(%map-enum args :symbol-int)
  57     (t (error 'type-error :datum ,form :expected-type '(enum ,@args)))))
  58
  59
  60 (defmethod from-alien-form (form (type (eql 'enum)) &rest args)
  61   (declare (ignore type))
  62   `(case ,form
  63     ,@(%map-enum args :int-quoted-symbol)))
  64
  65 (defmethod to-alien-function ((type (eql 'enum)) &rest args)
  66   (declare (ignore type))
  67   (let ((mappings (%map-enum args :symbol-int)))
  68     #'(lambda (enum)
  69         (or
  70          (second (assoc enum mappings))
  71          (error 'type-error :datum enum :expected-type (cons 'enum args))))))
  72
  73 (defmethod from-alien-function ((type (eql 'enum)) &rest args)
  74   (declare (ignore type))
  75   (let ((mappings (%map-enum args :int-symbol)))
  76     #'(lambda (int)
  77         (second (assoc int mappings)))))
  78
  79 (defmethod writer-function ((type (eql 'enum)) &rest args)
  80   (declare (ignore type))
  81   (let ((writer (writer-function 'signed))
  82         (function (apply #'to-alien-function 'enum args)))
  83     #'(lambda (enum location &optional (offset 0))
  84         (funcall writer (funcall function enum) location offset))))
  85
  86 (defmethod reader-function ((type (eql 'enum)) &rest args)
  87   (declare (ignore type))
  88   (let ((reader (reader-function 'signed))
  89         (function (apply #'from-alien-function 'enum args)))
  90     #'(lambda (location &optional (offset 0))
  91         (funcall function (funcall reader location offset)))))
  92
  93 (defun enum-int (enum type)
  94   (funcall (to-alien-function type) enum))
  95
  96 (defun int-enum (int type)
  97   (funcall (from-alien-function type) int))
  98
  99 (defun enum-mapping (type)
 100   (rest (type-expand-to 'enum type)))
 101
 102
 103 ;;;; Named enum types
 104
 105 (defmacro define-enum-type (name &rest args)
 106   (let ((enum-int (intern (format nil "~A-TO-INT" name)))
 107         (int-enum (intern (format nil "INT-TO-~A" name))))
 108     `(progn
 109        (deftype ,name () '(enum ,@args))
 110        (defun ,enum-int (enum)
 111          (case enum
 112            ,@(%map-enum args :symbol-int)
 113            (t (error 'type-error :datum enum :expected-type ',name))))
 114        (defun ,int-enum (value)
 115          (case value
 116            ,@(%map-enum args :int-quoted-symbol)))
 117        (defmethod to-alien-form (form (type (eql ',name)) &rest args)
 118          (declare (ignore type args))
 119          (list ',enum-int form))
 120        (defmethod from-alien-form (form (type (eql ',name)) &rest args)
 121          (declare (ignore type args))
 122          (list ',int-enum form))
 123        (defmethod to-alien-function ((type (eql ',name)) &rest args)
 124          (declare (ignore type args))
 125          #',enum-int)
 126        (defmethod from-alien-function ((type (eql ',name)) &rest args)
 127          (declare (ignore type args))
 128          #',int-enum)
 129        (defmethod writer-function ((type (eql ',name)) &rest args)
 130          (declare (ignore type args))
 131          (let ((writer (writer-function 'signed)))
 132            #'(lambda (enum location &optional (offset 0))
 133                (funcall writer (,enum-int enum) location offset))))
 134        (defmethod reader-function ((type (eql ',name)) &rest args)
 135          (declare (ignore type args))
 136          (let ((reader (reader-function 'signed)))
 137            #'(lambda (location &optional (offset 0))
 138                (,int-enum (funcall reader location offset))))))))
 139
 140
 141 ;;;;  Generic flags type
 142
 143 (defun %map-flags (mappings op)
 144   (loop
 145    as value = 1 then (ash value 1)
 146    for mapping in mappings
 147    collect (let ((symbol (if (atom mapping) mapping (first mapping))))
 148              (unless (atom mapping)
 149                (setq value (second mapping)))
 150              (ecase op
 151                (:symbol-int `(,symbol ,value))
 152                (:int-symbol `(,value ,symbol))
 153                (:symbols symbol)))))
 154
 155 (deftype flags (&rest args)
 156   `(or (member ,@(%map-flags args :symbols)) list))
 157
 158 (defmethod alien-type ((type (eql 'flags)) &rest args)
 159   (declare (ignore type args))
 160   (alien-type 'unsigned))
 161
 162 (defmethod size-of ((type (eql 'flags)) &rest args)
 163   (declare (ignore type args))
 164   (size-of 'unsigned))
 165
 166 (defmethod to-alien-form (flags (type (eql 'flags)) &rest args)
 167   `(reduce #'logior (mklist ,flags)
 168     :key #'(lambda (flag)
 169              (case flag
 170                ,@(%map-flags args :symbol-int)
 171                (t (error 'type-error :datum ,flags
 172                    :expected-type '(,type ,@args)))))))
 173
 174 (defmethod from-alien-form (value (type (eql 'flags)) &rest args)
 175   (declare (ignore type))
 176   `(loop
 177     for (int symbol)  in ',(%map-flags args :int-symbol)
 178     when (= (logand ,value int) int)
 179     collect symbol))
 180
 181 (defmethod to-alien-function ((type (eql 'flags)) &rest args)
 182   (declare (ignore type))
 183   (let ((mappings (%map-flags args :symbol-int)))
 184     #'(lambda (flags)
 185         (reduce #'logior (mklist flags)
 186          :key #'(lambda (flag)
 187                   (or
 188                    (second (assoc flag mappings))
 189                    (error 'type-error :datum flags
 190                     :expected-type (cons 'flags args))))))))
 191
 192 (defmethod from-alien-function ((type (eql 'flags)) &rest args)
 193   (declare (ignore type))
 194   (let ((mappings (%map-flags args :int-symbol)))
 195     #'(lambda (value)
 196         (loop
 197          for (int symbol) in mappings
 198          when (= (logand value int) int)
 199          collect symbol))))
 200
 201 (defmethod writer-function ((type (eql 'flags)) &rest args)
 202   (declare (ignore type))
 203   (let ((writer (writer-function 'unsigned))
 204         (function (apply #'to-alien-function 'flags args)))
 205     #'(lambda (flags location &optional (offset 0))
 206         (funcall writer (funcall function flags) location offset))))
 207
 208 (defmethod reader-function ((type (eql 'flags)) &rest args)
 209   (declare (ignore type))
 210   (let ((reader (reader-function 'unsigned))
 211         (function (apply #'from-alien-function 'flags args)))
 212     #'(lambda (location &optional (offset 0))
 213         (funcall function (funcall reader location offset)))))
 214
 215
 216 ;;;; Named flags types
 217
 218 (defmacro define-flags-type (name &rest args)
 219   (let ((flags-int (intern (format nil "~A-TO-INT" name)))
 220         (int-flags (intern (format nil "INT-TO-~A" name)))
 221         (satisfies  (intern (format nil "~A-P" name))))
 222     `(progn
 223        (deftype ,name () '(satisfies ,satisfies))
 224        (defun ,satisfies (object)
 225          (flet ((valid-p (ob)
 226                   (find ob ',(%map-flags args :symbols))))
 227            (typecase object
 228              (symbol (valid-p object))
 229              (list (every #'valid-p object)))))
 230        (defun ,flags-int (flags)
 231          (reduce #'logior (mklist flags)
 232           :key #'(lambda (flag)
 233                    (case flag
 234                      ,@(%map-flags args :symbol-int)
 235                      (t (error 'type-error :datum flags
 236                          :expected-type ',name))))))
 237        (defun ,int-flags (value)
 238          (loop
 239           for (int symbol) in ',(%map-flags args :int-symbol)
 240           when(= (logand value int) int)
 241           collect symbol))
 242        (defmethod alien-type ((type (eql ',name)) &rest args)
 243          (declare (ignore type args))
 244          (alien-type 'flags))
 245        (defmethod size-of ((type (eql ',name)) &rest args)
 246          (declare (ignore type args))
 247          (size-of 'flags))
 248        (defmethod to-alien-form (form (type (eql ',name)) &rest args)
 249          (declare (ignore type args))
 250          (list ',flags-int form))
 251        (defmethod from-alien-form (form (type (eql ',name)) &rest args)
 252          (declare (ignore type args))
 253          (list ',int-flags form))
 254        (defmethod to-alien-function ((type (eql ',name)) &rest args)
 255          (declare (ignore type args))
 256          #',flags-int)
 257        (defmethod from-alien-function ((type (eql ',name)) &rest args)
 258          (declare (ignore type args))
 259          #',int-flags)
 260        (defmethod writer-function ((type (eql ',name)) &rest args)
 261          (declare (ignore type args))
 262          (let ((writer (writer-function 'signed)))
 263            #'(lambda (flags location &optional (offset 0))
 264                (funcall writer (,flags-int flags) location offset))))
 265        (defmethod reader-function ((type (eql ',name)) &rest args)
 266          (declare (ignore type args))
 267          (let ((reader (reader-function 'signed)))
 268            #'(lambda (location &optional (offset 0))
 269                (,int-flags (funcall reader location offset))))))))
 270
 271
 272
 273 ;;;; Type definition by introspection
 274
 275 (defun %query-enum-or-flags-values (query-function class type)
 276   (multiple-value-bind (sap length)
 277       (funcall query-function (type-class-ref type))
 278     (let ((values nil)
 279           (size (foreign-size (find-class class)))
 280           (proxy (make-instance class :location sap)))
 281       (dotimes (i length)
 282         (with-slots (location nickname value) proxy
 283           (setf location sap)
 284           (setq sap (sap+ sap size))
 285           (push
 286            (list
 287             (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
 288             value)
 289            values)))
 290       values)))
 291
 292
 293 (defclass %enum-value (struct)
 294   ((value :allocation :alien :type int)
 295    (name :allocation :alien :type string)
 296    (nickname :allocation :alien :type string))
 297   (:metaclass static-struct-class))
 298
 299 (defbinding %enum-class-values () pointer
 300   (class pointer)
 301   (n-values unsigned-int :out))
 302
 303 (defun query-enum-values (type)
 304   (%query-enum-or-flags-values #'%enum-class-values '%enum-value type))
 305
 306
 307 (defclass %flags-value (struct)
 308   ((value :allocation :alien :type unsigned-int)
 309    (name :allocation :alien :type string)
 310    (nickname :allocation :alien :type string))
 311   (:metaclass static-struct-class))
 312
 313 (defbinding %flags-class-values () pointer
 314   (class pointer)
 315   (n-values unsigned-int :out))
 316
 317 (defun query-flags-values (type)
 318   (%query-enum-or-flags-values #'%flags-class-values '%flags-value type))
 319
 320
 321 (defun expand-enum-type (type-number forward-p options)
 322   (declare (ignore forward-p))
 323   (let* ((super (supertype type-number))
 324          (type (type-from-number type-number))
 325          (mappings (getf options :mappings))
 326          (expanded-mappings
 327           (append
 328            (delete-if
 329             #'(lambda (mapping)
 330                 (or
 331                  (assoc (first mapping) mappings)
 332                  (rassoc (cdr mapping) mappings :test #'equal)))
 333             (if (eq super 'enum)
 334                 (query-enum-values type-number)
 335               (query-flags-values type-number)))
 336            (remove-if
 337             #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
 338     `(progn
 339        (register-type ',type ',(find-type-init-function type-number))
 340        ,(ecase super
 341           (enum `(define-enum-type ,type ,@expanded-mappings))
 342           (flags `(define-flags-type ,type ,@expanded-mappings))))))
 343
 344
 345 (register-derivable-type 'enum "GEnum" 'expand-enum-type)
 346 (register-derivable-type 'flags "GFlags" 'expand-enum-type)
 347