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