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