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.3 2001-10-21 22:02:01 espen Exp $
  19
  20 (in-package "GLIB")
  21
  22
  23 (defun %map-mappings (args op)
  24   (let ((current-value 0))
  25     (map
  26      'list
  27      #'(lambda (mapping)
  28          (destructuring-bind (symbol &optional (value current-value))
  29              (mklist mapping)
  30            (setf current-value (1+ value))
  31            (case op
  32              (:enum-int (list symbol value))
  33              (:flags-int (list symbol value #|(ash 1 value)|#))
  34              (:int-enum (list value symbol))
  35              (:int-flags (list value #|(ash 1 value)|# symbol))
  36              (:symbols symbol))))
  37      (if (integerp (first args))
  38          (rest args)
  39        args))))
  40
  41 (defun %query-enum-or-flags-values (query-function class type)
  42   (multiple-value-bind (sap length)
  43       (funcall query-function (type-class-ref type))
  44     (let ((values nil)
  45           (size (proxy-class-size (find-class class)))
  46           (proxy (make-proxy-instance class sap nil)))
  47       (dotimes (i length)
  48         (with-slots (location nickname value) proxy
  49           (setf location sap)
  50           (setq sap (sap+ sap size))
  51           (push
  52            (list
  53             (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
  54             value)
  55            values)))
  56       values)))
  57
  58
  59 ;;;; Enum type
  60
  61 (deftype enum (&rest args)
  62   `(member ,@(%map-mappings args :symbols)))
  63
  64 (deftype-method translate-type-spec enum (type-spec)
  65   (let ((args (cdr (type-expand-to 'enum type-spec))))
  66     (if (integerp (first args))
  67         (translate-type-spec `(signed ,(first args)))
  68       (translate-type-spec 'signed))))
  69
  70 (deftype-method size-of enum (type-spec)
  71   (let ((args (cdr (type-expand-to 'enum type-spec))))
  72     (if (integerp (first args))
  73         (size-of `(signed ,(first args)))
  74       (size-of 'signed))))
  75
  76 (deftype-method translate-to-alien enum (type-spec expr &optional weak-ref)
  77   (declare (ignore weak-ref))
  78   (let ((args (cdr (type-expand-to 'enum type-spec))))
  79     `(ecase ,expr
  80        ,@(%map-mappings args :enum-int))))
  81
  82 (deftype-method translate-from-alien enum (type-spec expr &optional weak-ref)
  83   (declare (ignore weak-ref))
  84   (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec)
  85     (declare (ignore name))
  86     `(ecase ,expr
  87        ,@(%map-mappings args :int-enum))))
  88
  89 (eval-when (:compile-toplevel :load-toplevel :execute)
  90   (defclass %enum-value (static)
  91     ((value :allocation :alien :type int)
  92      (name :allocation :alien :type string)
  93      (nickname :allocation :alien :type string))
  94     (:metaclass proxy-class)))
  95
  96 (defbinding %enum-class-values () pointer
  97   (class pointer)
  98   (n-values unsigned-int :out))
  99
 100 (defun query-enum-values (type)
 101   (%query-enum-or-flags-values #'%enum-class-values '%enum-value type))
 102
 103
 104
 105 ;;;;  Flags type
 106
 107 (deftype flags (&rest args)
 108   `(or
 109     null
 110     (cons
 111      (member ,@(%map-mappings args :symbols))
 112      list)))
 113
 114 (deftype-method translate-type-spec flags (type-spec)
 115   (let ((args (cdr (type-expand-to 'flags type-spec))))
 116     (if (integerp (first args))
 117         (translate-type-spec `(unsigned ,(first args)))
 118       (translate-type-spec 'unsigned))))
 119
 120 (deftype-method size-of flags (type-spec)
 121   (let ((args (cdr (type-expand-to 'flags type-spec))))
 122     (if (integerp (first args))
 123         (size-of `(unsigned ,(first args)))
 124       (size-of 'unsigned))))
 125
 126 (deftype-method translate-to-alien flags (type-spec expr &optional weak-ref)
 127   (declare (ignore weak-ref))
 128   (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec)
 129     (declare (ignore name))
 130     (let ((mappings (%map-mappings args :flags-int))
 131           (value (make-symbol "VALUE")))
 132       `(let ((,value 0))
 133          (dolist (flag ,expr ,value)
 134            (setq ,value (logior ,value (second (assoc flag ',mappings)))))))))
 135
 136 (deftype-method translate-from-alien flags (type-spec expr &optional weak-ref)
 137   (declare (ignore weak-ref))
 138   (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec)
 139     (declare (ignore name))
 140     (let ((mappings (%map-mappings args :int-flags))
 141           (result (make-symbol "RESULT")))
 142       `(let ((,result nil))
 143          (dolist (mapping ',mappings ,result)
 144            (unless (zerop (logand ,expr (first mapping)))
 145              (push (second mapping) ,result)))))))
 146
 147
 148
 149 ;(eval-when (:compile-toplevel :load-toplevel :execute)
 150   (defclass %flags-value (static)
 151     ((value :allocation :alien :type unsigned-int)
 152      (name :allocation :alien :type string)
 153      (nickname :allocation :alien :type string))
 154     (:metaclass proxy-class));)
 155
 156 (defbinding %flags-class-values () pointer
 157   (class pointer)
 158   (n-values unsigned-int :out))
 159
 160 (defun query-flags-values (type)
 161   (%query-enum-or-flags-values #'%flags-class-values '%flags-value type))
 162
 163
 164
 165 ;;;;
 166
 167 (defun expand-enum-type (type-number &optional options)
 168   (let* ((super (supertype type-number))
 169          (type (type-from-number type-number))
 170          (mappings (getf options :mappings))
 171          (expanded-mappings
 172           (append
 173            (delete-if
 174             #'(lambda (mapping)
 175                 (or
 176                  (assoc (first mapping) mappings)
 177                  (rassoc (cdr mapping) mappings :test #'equal)))
 178             (if (eq super 'enum)
 179                 (query-enum-values type-number)
 180               (query-flags-values type-number)))
 181            (remove-if
 182             #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
 183     `(progn
 184        (register-type ',type ,(find-type-name type-number))
 185        (deftype ,type () '(,super ,@expanded-mappings)))))
 186
 187
 188 (register-derivable-type 'enum "GEnum" 'expand-enum-type)
 189 (register-derivable-type 'flags "GFlags" 'expand-enum-type)
 190