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.1 2001-04-29 20:19:25 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
  42 ;;;; Enum type
  43
  44 (deftype enum (&rest args)
  45   `(member ,@(%map-mappings args :symbols)))
  46
  47 (deftype-method translate-type-spec enum (type-spec)
  48   (let ((args (cdr (type-expand-to 'enum type-spec))))
  49     (if (integerp (first args))
  50         (translate-type-spec `(signed ,(first args)))
  51       (translate-type-spec 'signed))))
  52
  53 (deftype-method size-of enum (type-spec)
  54   (let ((args (cdr (type-expand-to 'enum type-spec))))
  55     (if (integerp (first args))
  56         (size-of `(signed ,(first args)))
  57       (size-of 'signed))))
  58
  59 (deftype-method translate-to-alien enum (type-spec expr &optional weak-ref)
  60   (declare (ignore weak-ref))
  61   (let ((args (cdr (type-expand-to 'enum type-spec))))
  62     `(ecase ,expr
  63        ,@(%map-mappings args :enum-int))))
  64
  65 (deftype-method translate-from-alien enum (type-spec expr &optional weak-ref)
  66   (declare (ignore weak-ref))
  67   (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec)
  68     (declare (ignore name))
  69     `(ecase ,expr
  70        ,@(%map-mappings args :int-enum))))
  71
  72 (setf (alien-type-name 'enum) "GEnum")
  73
  74 (eval-when (:compile-toplevel :load-toplevel :execute)
  75   (defclass %enum-value (alien-structure)
  76     ((value :allocation :alien :type int)
  77      (name :allocation :alien :type string)
  78      (nickname :allocation :alien :type string))
  79     (:metaclass proxy-class)))
  80
  81 (defbinding %enum-class-values () (glist %enum-value)
  82   (class pointer))
  83
  84 (defun %query-enum-values (type-number)
  85   (mapcar
  86    #'(lambda (enum-value)
  87        (list
  88         (intern
  89          (substitute
  90           #\- #\_ (string-upcase (slot-value enum-value 'nickname))) "KEYWORD")
  91         (slot-value enum-value 'value)))
  92    (%enum-class-values (type-class-peek type-number))))
  93
  94 (defun define-enum-by-query (init-fname &optional name)
  95   (let ((type-number (type-init name init-fname)))
  96     (unless (= (type-parent type-number) (find-type-number 'enum))
  97       (error "~A is not an enum type" (alien-type-name type-number)))
  98
  99     (type-class-ref type-number)
 100     (setf (find-type-number name) type-number)
 101     (let ((expanded (cons 'enum (%query-enum-values type-number)))
 102           (name (or name (default-type-name (alien-type-name type-number)))))
 103       (lisp::%deftype
 104        name
 105        #'(lambda (whole)
 106            (unless (zerop (length (cdr whole)))
 107              (lisp::do-arg-count-error 'deftype name (cdr whole) nil 0 0))
 108            expanded)))))
 109
 110
 111 ;;;;  Flags type
 112
 113 (deftype flags (&rest args)
 114   `(or
 115     null
 116     (cons
 117      (member ,@(%map-mappings args :symbols))
 118      list)))
 119
 120 (deftype-method translate-type-spec flags (type-spec)
 121   (let ((args (cdr (type-expand-to 'flags type-spec))))
 122     (if (integerp (first args))
 123         (translate-type-spec `(unsigned ,(first args)))
 124       (translate-type-spec 'unsigned))))
 125
 126 (deftype-method size-of flags (type-spec)
 127   (let ((args (cdr (type-expand-to 'flags type-spec))))
 128     (if (integerp (first args))
 129         (size-of `(unsigned ,(first args)))
 130       (size-of 'unsigned))))
 131
 132 (deftype-method translate-to-alien flags (type-spec expr &optional weak-ref)
 133   (declare (ignore weak-ref))
 134   (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec)
 135     (declare (ignore name))
 136     (let ((mappings (%map-mappings args :flags-int))
 137           (value (make-symbol "VALUE")))
 138       `(let ((,value 0))
 139          (dolist (flag ,expr ,value)
 140            (setq ,value (logior ,value (second (assoc flag ',mappings)))))))))
 141
 142 (deftype-method translate-from-alien flags (type-spec expr &optional weak-ref)
 143   (declare (ignore weak-ref))
 144   (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec)
 145     (declare (ignore name))
 146     (let ((mappings (%map-mappings args :int-flags))
 147           (result (make-symbol "RESULT")))
 148       `(let ((,result nil))
 149          (dolist (mapping ',mappings ,result)
 150            (unless (zerop (logand ,expr (first mapping)))
 151              (push (second mapping) ,result)))))))
 152
 153 (setf (alien-type-name 'flags) "GFlags")
 154
 155
 156 (eval-when (:compile-toplevel :load-toplevel :execute)
 157   (defclass %flags-value (alien-structure)
 158     ((value :allocation :alien :type unsigned-int)
 159      (name :allocation :alien :type string)
 160      (nickname :allocation :alien :type string))
 161     (:metaclass proxy-class)))
 162
 163 (defbinding %flags-class-values () (glist %flags-value)
 164   (class pointer))
 165
 166 (defun %query-flags-values (type-number)
 167   (mapcar
 168    #'(lambda (flags-value)
 169        (list
 170         (intern
 171          (substitute
 172           #\- #\_ (string-upcase (slot-value flags-value 'nickname))) "KEYWORD")
 173         (slot-value flags-value 'value)))
 174    (%flags-class-values (type-class-peek type-number))))
 175
 176 (defun define-flags-by-query (init-fname &optional name)
 177   (let ((type-number (type-init nil init-fname)))
 178     (unless (= (type-parent type-number) (find-type-number 'flags))
 179       (error "~A is not a flags type" (alien-type-name type-number)))
 180
 181     (type-class-ref type-number)
 182     (setf (find-type-number name) type-number)
 183     (let ((expanded (cons 'flags (%query-flags-values type-number)))
 184           (name (or name (default-type-name (alien-type-name type-number)))))
 185       (lisp::%deftype
 186        name
 187        #'(lambda (whole)
 188            (unless (zerop (length (cdr whole)))
 189              (lisp::do-arg-count-error 'deftype name (cdr whole) nil 0 0))
 190            expanded)))))