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