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.17 2006-02-06 18:12:19 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) weak-p)
  91         (declare (ignore weak-p))
  92         (funcall function (funcall reader location offset)))))
  93
  94 (defun enum-int (enum type)
  95   (funcall (to-alien-function type) enum))
  96
  97 (defun int-enum (int type)
  98   (funcall (from-alien-function type) int))
  99
 100 (defun enum-mapping (type)
 101   (rest (type-expand-to 'enum type)))
 102
 103
 104 ;;;; Named enum types
 105
 106 (defmacro define-enum-type (name &rest args)
 107   (let ((enum-int (intern (format nil "~A-TO-INT" name)))
 108         (int-enum (intern (format nil "INT-TO-~A" name))))
 109     `(progn
 110        (deftype ,name () '(enum ,@args))
 111        (defun ,enum-int (enum)
 112          (case enum
 113            ,@(%map-enum args :symbol-int)
 114            (t (error 'type-error :datum enum :expected-type ',name))))
 115        (defun ,int-enum (value)
 116          (case value
 117            ,@(%map-enum args :int-quoted-symbol)))
 118        (defmethod to-alien-form (form (type (eql ',name)) &rest args)
 119          (declare (ignore type args))
 120          (list ',enum-int form))
 121        (defmethod from-alien-form (form (type (eql ',name)) &rest args)
 122          (declare (ignore type args))
 123          (list ',int-enum form))
 124        (defmethod to-alien-function ((type (eql ',name)) &rest args)
 125          (declare (ignore type args))
 126          #',enum-int)
 127        (defmethod from-alien-function ((type (eql ',name)) &rest args)
 128          (declare (ignore type args))
 129          #',int-enum)
 130        (defmethod writer-function ((type (eql ',name)) &rest args)
 131          (declare (ignore type args))
 132          (let ((writer (writer-function 'signed)))
 133            #'(lambda (enum location &optional (offset 0))
 134                (funcall writer (,enum-int enum) location offset))))
 135        (defmethod reader-function ((type (eql ',name)) &rest args)
 136          (declare (ignore type args))
 137          (let ((reader (reader-function 'signed)))
 138            #'(lambda (location &optional (offset 0) weak-p)
 139                (declare (ignore weak-p))
 140                (,int-enum (funcall reader location offset))))))))
 141
 142
 143 ;;;;  Generic flags type
 144
 145 (defun %map-flags (mappings op)
 146   (loop
 147    as value = 1 then (ash value 1)
 148    for mapping in mappings
 149    collect (let ((symbol (if (atom mapping) mapping (first mapping))))
 150              (unless (atom mapping)
 151                (setq value (second mapping)))
 152              (ecase op
 153                (:symbol-int `(,symbol ,value))
 154                (:int-symbol `(,value ,symbol))
 155                (:symbols symbol)))))
 156
 157 (deftype flags (&rest args)
 158   `(or (member ,@(%map-flags args :symbols)) list))
 159
 160 (defmethod alien-type ((type (eql 'flags)) &rest args)
 161   (declare (ignore type args))
 162   (alien-type 'unsigned))
 163
 164 (defmethod size-of ((type (eql 'flags)) &rest args)
 165   (declare (ignore type args))
 166   (size-of 'unsigned))
 167
 168 (defmethod to-alien-form (flags (type (eql 'flags)) &rest args)
 169   `(reduce #'logior (mklist ,flags)
 170     :key #'(lambda (flag)
 171              (case flag
 172                ,@(%map-flags args :symbol-int)
 173                (t (error 'type-error :datum ,flags
 174                    :expected-type '(,type ,@args)))))))
 175
 176 (defmethod from-alien-form (value (type (eql 'flags)) &rest args)
 177   (declare (ignore type))
 178   `(loop
 179     for (int symbol)  in ',(%map-flags args :int-symbol)
 180     when (= (logand ,value int) int)
 181     collect symbol))
 182
 183 (defmethod to-alien-function ((type (eql 'flags)) &rest args)
 184   (declare (ignore type))
 185   (let ((mappings (%map-flags args :symbol-int)))
 186     #'(lambda (flags)
 187         (reduce #'logior (mklist flags)
 188          :key #'(lambda (flag)
 189                   (or
 190                    (second (assoc flag mappings))
 191                    (error 'type-error :datum flags
 192                     :expected-type (cons 'flags args))))))))
 193
 194 (defmethod from-alien-function ((type (eql 'flags)) &rest args)
 195   (declare (ignore type))
 196   (let ((mappings (%map-flags args :int-symbol)))
 197     #'(lambda (value)
 198         (loop
 199          for (int symbol) in mappings
 200          when (= (logand value int) int)
 201          collect symbol))))
 202
 203 (defmethod writer-function ((type (eql 'flags)) &rest args)
 204   (declare (ignore type))
 205   (let ((writer (writer-function 'unsigned))
 206         (function (apply #'to-alien-function 'flags args)))
 207     #'(lambda (flags location &optional (offset 0))
 208         (funcall writer (funcall function flags) location offset))))
 209
 210 (defmethod reader-function ((type (eql 'flags)) &rest args)
 211   (declare (ignore type))
 212   (let ((reader (reader-function 'unsigned))
 213         (function (apply #'from-alien-function 'flags args)))
 214     #'(lambda (location &optional (offset 0) weak-p)
 215         (declare (ignore weak-p))
 216         (funcall function (funcall reader location offset)))))
 217
 218
 219 ;;;; Named flags types
 220
 221 (defmacro define-flags-type (name &rest args)
 222   (let ((flags-int (intern (format nil "~A-TO-INT" name)))
 223         (int-flags (intern (format nil "INT-TO-~A" name)))
 224         (satisfies  (intern (format nil "~A-P" name))))
 225     `(progn
 226        (deftype ,name () '(satisfies ,satisfies))
 227        (defun ,satisfies (object)
 228          (flet ((valid-p (ob)
 229                   (find ob ',(%map-flags args :symbols))))
 230            (typecase object
 231              (symbol (valid-p object))
 232              (list (every #'valid-p object)))))
 233        (defun ,flags-int (flags)
 234          (reduce #'logior (mklist flags)
 235           :key #'(lambda (flag)
 236                    (case flag
 237                      ,@(%map-flags args :symbol-int)
 238                      (t (error 'type-error :datum flags
 239                          :expected-type ',name))))))
 240        (defun ,int-flags (value)
 241          (loop
 242           for (int symbol) in ',(%map-flags args :int-symbol)
 243           when(= (logand value int) int)
 244           collect symbol))
 245        (defmethod alien-type ((type (eql ',name)) &rest args)
 246          (declare (ignore type args))
 247          (alien-type 'flags))
 248        (defmethod size-of ((type (eql ',name)) &rest args)
 249          (declare (ignore type args))
 250          (size-of 'flags))
 251        (defmethod to-alien-form (form (type (eql ',name)) &rest args)
 252          (declare (ignore type args))
 253          (list ',flags-int form))
 254        (defmethod from-alien-form (form (type (eql ',name)) &rest args)
 255          (declare (ignore type args))
 256          (list ',int-flags form))
 257        (defmethod to-alien-function ((type (eql ',name)) &rest args)
 258          (declare (ignore type args))
 259          #',flags-int)
 260        (defmethod from-alien-function ((type (eql ',name)) &rest args)
 261          (declare (ignore type args))
 262          #',int-flags)
 263        (defmethod writer-function ((type (eql ',name)) &rest args)
 264          (declare (ignore type args))
 265          (let ((writer (writer-function 'signed)))
 266            #'(lambda (flags location &optional (offset 0))
 267                (funcall writer (,flags-int flags) location offset))))
 268        (defmethod reader-function ((type (eql ',name)) &rest args)
 269          (declare (ignore type args))
 270          (let ((reader (reader-function 'signed)))
 271            #'(lambda (location &optional (offset 0) weak-p)
 272                (declare (ignore weak-p))
 273                (,int-flags (funcall reader location offset))))))))
 274
 275
 276
 277 ;;;; Type definition by introspection
 278
 279 (defun %query-enum-or-flags-values (query-function class type)
 280   (multiple-value-bind (sap length)
 281       (funcall query-function (type-class-ref type))
 282     (let ((values nil)
 283           (size (foreign-size (find-class class)))
 284           (proxy (ensure-proxy-instance class sap)))
 285       (dotimes (i length)
 286         (with-slots (location nickname value) proxy
 287           (setf location sap)
 288           (setq sap (sap+ sap size))
 289           (push
 290            (list
 291             (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
 292             value)
 293            values)))
 294       values)))
 295
 296
 297 (defclass %enum-value (struct)
 298   ((value :allocation :alien :type int)
 299    (name :allocation :alien :type string)
 300    (nickname :allocation :alien :type string))
 301   (:metaclass static-struct-class))
 302
 303 (defbinding %enum-class-values () pointer
 304   (class pointer)
 305   (n-values unsigned-int :out))
 306
 307 (defun query-enum-values (type)
 308   (%query-enum-or-flags-values #'%enum-class-values '%enum-value type))
 309
 310
 311 (defclass %flags-value (struct)
 312   ((value :allocation :alien :type unsigned-int)
 313    (name :allocation :alien :type string)
 314    (nickname :allocation :alien :type string))
 315   (:metaclass static-struct-class))
 316
 317 (defbinding %flags-class-values () pointer
 318   (class pointer)
 319   (n-values unsigned-int :out))
 320
 321 (defun query-flags-values (type)
 322   (%query-enum-or-flags-values #'%flags-class-values '%flags-value type))
 323
 324
 325 (defun expand-enum-type (type-number forward-p options)
 326   (declare (ignore forward-p))
 327   (let* ((super (supertype type-number))
 328          (type (type-from-number type-number))
 329          (mappings (getf options :mappings))
 330          (expanded-mappings
 331           (append
 332            (delete-if
 333             #'(lambda (mapping)
 334                 (or
 335                  (assoc (first mapping) mappings)
 336                  (rassoc (cdr mapping) mappings :test #'equal)))
 337             (if (eq super 'enum)
 338                 (query-enum-values type-number)
 339               (query-flags-values type-number)))
 340            (remove-if
 341             #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
 342     `(progn
 343        (register-type ',type ',(find-type-init-function type-number))
 344        ,(ecase super
 345           (enum `(define-enum-type ,type ,@expanded-mappings))
 346           (flags `(define-flags-type ,type ,@expanded-mappings))))))
 347
 348
 349 (register-derivable-type 'enum "GEnum" 'expand-enum-type)
 350 (register-derivable-type 'flags "GFlags" 'expand-enum-type)
 351