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

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
   3 ;;
   4 ;; This library is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU Lesser General Public
   6 ;; License as published by the Free Software Foundation; either
   7 ;; version 2 of the License, or (at your option) any later version.
   8 ;;
   9 ;; This library is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;; Lesser General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU Lesser General Public
  15 ;; License along with this library; if not, write to the Free Software
  16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 ;; $Id: genums.lisp,v 1.12 2005-03-06 17:26:23 espen Exp $
  19
  20 (in-package "GLIB")
  21
  22 ;;;; Generic enum type
  23
  24 (defun %map-enum (mappings op)
  25   (loop
  26    as value = 0 then (1+ value)
  27    for mapping in mappings
  28    collect (let ((symbol (if (atom mapping) mapping (first mapping))))
  29              (unless (atom mapping)
  30                (setq value (second mapping)))
  31              (ecase op
  32                (:symbol-int `(,symbol ,value))
  33                (:int-symbol `(,value ,symbol))
  34                (:int-quoted-symbol `(,value ',symbol))
  35                (:symbols symbol)))))
  36
  37 (deftype enum (&rest args)
  38   `(member ,@(%map-enum args :symbols)))
  39
  40 (defmethod alien-type ((type (eql 'enum)) &rest args)
  41   (declare (ignore type args))
  42   (alien-type 'signed))
  43
  44 (defmethod size-of ((type (eql 'enum)) &rest args)
  45   (declare (ignore type args))
  46   (size-of 'signed))
  47
  48 (defmethod to-alien-form (form (type (eql 'enum)) &rest args)
  49   (declare (ignore type))
  50   `(case ,form
  51     ,@(%map-enum args :symbol-int)
  52     (t (error 'type-error :datum ,form :expected-type '(enum ,@args)))))
  53
  54
  55 (defmethod from-alien-form (form (type (eql 'enum)) &rest args)
  56   (declare (ignore type))
  57   `(case ,form
  58     ,@(%map-enum args :int-quoted-symbol)))
  59
  60 (defmethod to-alien-function ((type (eql 'enum)) &rest args)
  61   (declare (ignore type))
  62   (let ((mappings (%map-enum args :symbol-int)))
  63     #'(lambda (enum)
  64         (or
  65          (second (assoc enum mappings))
  66          (error 'type-error :datum enum :expected-type (cons 'enum args))))))
  67
  68 (defmethod from-alien-function ((type (eql 'enum)) &rest args)
  69   (declare (ignore type))
  70   (let ((mappings (%map-enum args :int-symbol)))
  71     #'(lambda (int)
  72         (second (assoc int mappings)))))
  73
  74 (defmethod writer-function ((type (eql 'enum)) &rest args)
  75   (declare (ignore type))
  76   (let ((writer (writer-function 'signed))
  77         (function (apply #'to-alien-function 'enum args)))
  78     #'(lambda (enum location &optional (offset 0))
  79         (funcall writer (funcall function enum) location offset))))
  80
  81 (defmethod reader-function ((type (eql 'enum)) &rest args)
  82   (declare (ignore type))
  83   (let ((reader (reader-function 'signed))
  84         (function (apply #'from-alien-function 'enum args)))
  85     #'(lambda (location &optional (offset 0))
  86         (funcall function (funcall reader location offset)))))
  87
  88 (defun enum-int (enum type)
  89   (funcall (to-alien-function type) enum))
  90
  91 (defun int-enum (int type)
  92   (funcall (from-alien-function type) int))
  93
  94 (defun enum-mapping (type)
  95   (rest (type-expand-to 'enum type)))
  96
  97
  98 ;;;; Named enum types
  99
 100 (defmacro define-enum-type (name &rest args)
 101   (let ((enum-int (intern (format nil "~A-TO-INT" name)))
 102         (int-enum (intern (format nil "INT-TO-~A" name))))
 103     `(progn
 104        (deftype ,name () '(enum ,@args))
 105        (defun ,enum-int (enum)
 106          (case enum
 107            ,@(%map-enum args :symbol-int)
 108            (t (error 'type-error :datum enum :expected-type ',name))))
 109        (defun ,int-enum (value)
 110          (case value
 111            ,@(%map-enum args :int-quoted-symbol)))
 112        (defmethod to-alien-form (form (type (eql ',name)) &rest args)
 113          (declare (ignore type args))
 114          (list ',enum-int form))
 115        (defmethod from-alien-form (form (type (eql ',name)) &rest args)
 116          (declare (ignore type args))
 117          (list ',int-enum form))
 118        (defmethod to-alien-function ((type (eql ',name)) &rest args)
 119          (declare (ignore type args))
 120          #',enum-int)
 121        (defmethod from-alien-function ((type (eql ',name)) &rest args)
 122          (declare (ignore type args))
 123          #',int-enum)
 124        (defmethod writer-function ((type (eql ',name)) &rest args)
 125          (declare (ignore type args))
 126          (let ((writer (writer-function 'signed)))
 127            #'(lambda (enum location &optional (offset 0))
 128                (funcall writer (,enum-int enum) location offset))))
 129        (defmethod reader-function ((type (eql ',name)) &rest args)
 130          (declare (ignore type args))
 131          (let ((reader (reader-function 'signed)))
 132            #'(lambda (location &optional (offset 0))
 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 (defmethod alien-type ((type (eql 'flags)) &rest args)
 154   (declare (ignore type args))
 155   (alien-type 'unsigned))
 156
 157 (defmethod size-of ((type (eql 'flags)) &rest args)
 158   (declare (ignore type args))
 159   (size-of 'unsigned))
 160
 161 (defmethod to-alien-form (flags (type (eql 'flags)) &rest args)
 162   `(reduce #'logior (mklist ,flags)
 163     :key #'(lambda (flag)
 164              (case flag
 165                ,@(%map-flags args :symbol-int)
 166                (t (error 'type-error :datum ,flags
 167                    :expected-type '(,type ,@args)))))))
 168
 169 (defmethod from-alien-form (int (type (eql 'flags)) &rest args)
 170   (declare (ignore type))
 171   `(loop
 172     for mapping in ',(%map-flags args :int-symbol)
 173     unless (zerop (logand ,int (first mapping)))
 174     collect (second mapping)))
 175
 176 (defmethod to-alien-function ((type (eql 'flags)) &rest args)
 177   (declare (ignore type))
 178   (let ((mappings (%map-flags args :symbol-int)))
 179     #'(lambda (flags)
 180         (reduce #'logior (mklist flags)
 181          :key #'(lambda (flag)
 182                   (or
 183                    (second (assoc flag mappings))
 184                    (error 'type-error :datum flags
 185                     :expected-type (cons 'flags args))))))))
 186
 187 (defmethod from-alien-function ((type (eql 'flags)) &rest args)
 188   (declare (ignore type))
 189   (let ((mappings (%map-flags args :int-symbol)))
 190     #'(lambda (int)
 191         (loop
 192          for mapping in mappings
 193          unless (zerop (logand int (first mapping)))
 194          collect (second mapping)))))
 195
 196 (defmethod writer-function ((type (eql 'flags)) &rest args)
 197   (declare (ignore type))
 198   (let ((writer (writer-function 'unsigned))
 199         (function (apply #'to-alien-function 'flags args)))
 200     #'(lambda (flags location &optional (offset 0))
 201         (funcall writer (funcall function flags) location offset))))
 202
 203 (defmethod reader-function ((type (eql 'flags)) &rest args)
 204   (declare (ignore type))
 205   (let ((reader (reader-function 'unsigned))
 206         (function (apply #'from-alien-function 'flags args)))
 207     #'(lambda (location &optional (offset 0))
 208         (funcall function (funcall reader location offset)))))
 209
 210
 211 ;;;; Named flags types
 212
 213 (defmacro define-flags-type (name &rest args)
 214   (let ((flags-int (intern (format nil "~A-TO-INT" name)))
 215         (int-flags (intern (format nil "INT-TO-~A" name)))
 216         (satisfies  (intern (format nil "~A-P" name))))
 217     `(progn
 218        (deftype ,name () '(satisfies ,satisfies))
 219        (defun ,satisfies (object)
 220          (flet ((valid-p (ob)
 221                   (find ob ',(%map-flags args :symbols))))
 222            (typecase object
 223              (symbol (valid-p object))
 224              (list (every #'valid-p object)))))
 225        (defun ,flags-int (flags)
 226          (reduce #'logior (mklist flags)
 227           :key #'(lambda (flag)
 228                    (case flag
 229                      ,@(%map-flags args :symbol-int)
 230                      (t (error 'type-error :datum flags
 231                          :expected-type ',name))))))
 232        (defun ,int-flags (value)
 233          (loop
 234           for mapping in ',(%map-flags args :int-symbol)
 235           unless (zerop (logand value (first mapping)))
 236           collect (second mapping)))
 237        (defmethod alien-type ((type (eql ',name)) &rest args)
 238          (declare (ignore type args))
 239          (alien-type 'flags))
 240        (defmethod size-of ((type (eql ',name)) &rest args)
 241          (declare (ignore type args))
 242          (size-of 'flags))
 243        (defmethod to-alien-form (form (type (eql ',name)) &rest args)
 244          (declare (ignore type args))
 245          (list ',flags-int form))
 246        (defmethod from-alien-form (form (type (eql ',name)) &rest args)
 247          (declare (ignore type args))
 248          (list ',int-flags form))
 249        (defmethod to-alien-function ((type (eql ',name)) &rest args)
 250          (declare (ignore type args))
 251          #',flags-int)
 252        (defmethod from-alien-function ((type (eql ',name)) &rest args)
 253          (declare (ignore type args))
 254          #',int-flags)
 255        (defmethod writer-function ((type (eql ',name)) &rest args)
 256          (declare (ignore type args))
 257          (let ((writer (writer-function 'signed)))
 258            #'(lambda (flags location &optional (offset 0))
 259                (funcall writer (,flags-int flags) location offset))))
 260        (defmethod reader-function ((type (eql ',name)) &rest args)
 261          (declare (ignore type args))
 262          (let ((reader (reader-function 'signed)))
 263            #'(lambda (location &optional (offset 0))
 264                (,int-flags (funcall reader location offset))))))))
 265
 266
 267
 268 ;;;; Type definition by introspection
 269
 270 (defun %query-enum-or-flags-values (query-function class type)
 271   (multiple-value-bind (sap length)
 272       (funcall query-function (type-class-ref type))
 273     (let ((values nil)
 274           (size (proxy-instance-size (find-class class)))
 275           (proxy (make-instance class :location sap)))
 276       (dotimes (i length)
 277         (with-slots (location nickname value) proxy
 278           (setf location sap)
 279           (setq sap (sap+ sap size))
 280           (push
 281            (list
 282             (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
 283             value)
 284            values)))
 285       values)))
 286
 287
 288 (defclass %enum-value (struct)
 289   ((value :allocation :alien :type int)
 290    (name :allocation :alien :type string)
 291    (nickname :allocation :alien :type string))
 292   (:metaclass static-struct-class))
 293
 294 (defbinding %enum-class-values () pointer
 295   (class pointer)
 296   (n-values unsigned-int :out))
 297
 298 (defun query-enum-values (type)
 299   (%query-enum-or-flags-values #'%enum-class-values '%enum-value type))
 300
 301
 302 (defclass %flags-value (struct)
 303   ((value :allocation :alien :type unsigned-int)
 304    (name :allocation :alien :type string)
 305    (nickname :allocation :alien :type string))
 306   (:metaclass static-struct-class))
 307
 308 (defbinding %flags-class-values () pointer
 309   (class pointer)
 310   (n-values unsigned-int :out))
 311
 312 (defun query-flags-values (type)
 313   (%query-enum-or-flags-values #'%flags-class-values '%flags-value type))
 314
 315
 316 (defun expand-enum-type (type-number forward-p options)
 317   (declare (ignore forward-p))
 318   (let* ((super (supertype type-number))
 319          (type (type-from-number type-number))
 320          (mappings (getf options :mappings))
 321          (expanded-mappings
 322           (append
 323            (delete-if
 324             #'(lambda (mapping)
 325                 (or
 326                  (assoc (first mapping) mappings)
 327                  (rassoc (cdr mapping) mappings :test #'equal)))
 328             (if (eq super 'enum)
 329                 (query-enum-values type-number)
 330               (query-flags-values type-number)))
 331            (remove-if
 332             #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
 333     `(progn
 334        (register-type ',type ',(find-type-init-function type-number))
 335        ,(ecase super
 336           (enum `(define-enum-type ,type ,@expanded-mappings))
 337           (flags `(define-flags-type ,type ,@expanded-mappings))))))
 338
 339
 340 (register-derivable-type 'enum "GEnum" 'expand-enum-type)
 341 (register-derivable-type 'flags "GFlags" 'expand-enum-type)
 342