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