external/cffi.darcs/_darcs/pristine/src/enum.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; enum.lisp --- Defining foreign constants as Lisp keywords.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, James Bielman  <jamesjb@jamesjb.com>
   6 ;;;
   7 ;;; Permission is hereby granted, free of charge, to any person
   8 ;;; obtaining a copy of this software and associated documentation
   9 ;;; files (the "Software"), to deal in the Software without
  10 ;;; restriction, including without limitation the rights to use, copy,
  11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12 ;;; of the Software, and to permit persons to whom the Software is
  13 ;;; furnished to do so, subject to the following conditions:
  14 ;;;
  15 ;;; The above copyright notice and this permission notice shall be
  16 ;;; included in all copies or substantial portions of the Software.
  17 ;;;
  18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  25 ;;; DEALINGS IN THE SOFTWARE.
  26 ;;;
  27
  28 (in-package #:cffi)
  29
  30 ;;;# Foreign Constants as Lisp Keywords
  31 ;;;
  32 ;;; This module defines the DEFCENUM macro, which provides an
  33 ;;; interface for defining a type and associating a set of integer
  34 ;;; constants with keyword symbols for that type.
  35 ;;;
  36 ;;; The keywords are automatically translated to the appropriate
  37 ;;; constant for the type by a type translator when passed as
  38 ;;; arguments or a return value to a foreign function.
  39
  40 (defclass foreign-enum (foreign-typedef enhanced-foreign-type)
  41   ((keyword-values
  42     :initform (make-hash-table :test 'eq)
  43     :reader keyword-values)
  44    (value-keywords
  45     :initform (make-hash-table)
  46     :reader value-keywords))
  47   (:documentation "Describes a foreign enumerated type."))
  48
  49 (defun make-foreign-enum (type-name base-type values)
  50   "Makes a new instance of the foreign-enum class."
  51   (let ((type (make-instance 'foreign-enum :name type-name
  52                              :actual-type (parse-type base-type)))
  53         (default-value 0))
  54     (dolist (pair values)
  55       (destructuring-bind (keyword &optional (value default-value))
  56           (ensure-list pair)
  57         (check-type keyword keyword)
  58         (check-type value integer)
  59         (if (gethash keyword (keyword-values type))
  60             (error "A foreign enum cannot contain duplicate keywords: ~S."
  61                    keyword)
  62             (setf (gethash keyword (keyword-values type)) value))
  63         ;; This is completely arbitrary behaviour: we keep the last we
  64         ;; value->keyword mapping. I suppose the opposite would be
  65         ;; just as good (keeping the first). Returning a list with all
  66         ;; the keywords might be a solution too? Suggestions
  67         ;; welcome. --luis
  68         (setf (gethash value (value-keywords type)) keyword)
  69         (setq default-value (1+ value))))
  70     type))
  71
  72 (defmacro defcenum (name-and-options &body enum-list)
  73   "Define an foreign enumerated type."
  74   (discard-docstring enum-list)
  75   (destructuring-bind (name &optional (base-type :int))
  76       (ensure-list name-and-options)
  77     `(eval-when (:compile-toplevel :load-toplevel :execute)
  78        (notice-foreign-type
  79         ',name (make-foreign-enum ',name ',base-type ',enum-list)))))
  80
  81 (defun hash-keys-to-list (ht)
  82   (loop for k being the hash-keys in ht collect k))
  83
  84 (defun foreign-enum-keyword-list (enum-type)
  85   "Return a list of KEYWORDS defined in ENUM-TYPE."
  86   (hash-keys-to-list (keyword-values (parse-type enum-type))))
  87
  88 ;;; These [four] functions could be good canditates for compiler macros
  89 ;;; when the value or keyword is constant.  I am not going to bother
  90 ;;; until someone has a serious performance need to do so though. --jamesjb
  91 (defun %foreign-enum-value (type keyword &key errorp)
  92   (check-type keyword keyword)
  93   (or (gethash keyword (keyword-values type))
  94       (when errorp
  95         (error "~S is not defined as a keyword for enum type ~S."
  96                keyword type))))
  97
  98 (defun foreign-enum-value (type keyword &key (errorp t))
  99   "Convert a KEYWORD into an integer according to the enum TYPE."
 100   (let ((type-obj (parse-type type)))
 101     (if (not (typep type-obj 'foreign-enum))
 102       (error "~S is not a foreign enum type." type)
 103       (%foreign-enum-value type-obj keyword :errorp errorp))))
 104
 105 (defun %foreign-enum-keyword (type value &key errorp)
 106   (check-type value integer)
 107   (or (gethash value (value-keywords type))
 108       (when errorp
 109         (error "~S is not defined as a value for enum type ~S."
 110                value type))))
 111
 112 (defun foreign-enum-keyword (type value &key (errorp t))
 113   "Convert an integer VALUE into a keyword according to the enum TYPE."
 114   (let ((type-obj (parse-type type)))
 115     (if (not (typep type-obj 'foreign-enum))
 116         (error "~S is not a foreign enum type." type)
 117         (%foreign-enum-keyword type-obj value :errorp errorp))))
 118
 119 (defmethod translate-to-foreign (value (type foreign-enum))
 120   (if (keywordp value)
 121       (%foreign-enum-value type value :errorp t)
 122       value))
 123
 124 (defmethod translate-from-foreign (value (type foreign-enum))
 125   (%foreign-enum-keyword type value :errorp t))
 126
 127 ;;;# Foreign Bitfields as Lisp keywords
 128 ;;;
 129 ;;; DEFBITFIELD is an abstraction similar to the one provided by DEFCENUM.
 130 ;;; With some changes to DEFCENUM, this could certainly be implemented on
 131 ;;; top of it.
 132
 133 (defclass foreign-bitfield (foreign-typedef enhanced-foreign-type)
 134   ((symbol-values
 135     :initform (make-hash-table :test 'eq)
 136     :reader symbol-values)
 137    (value-symbols
 138     :initform (make-hash-table)
 139     :reader value-symbols))
 140   (:documentation "Describes a foreign bitfield type."))
 141
 142 (defun make-foreign-bitfield (type-name base-type values)
 143   "Makes a new instance of the foreign-bitfield class."
 144   (let ((type (make-instance 'foreign-bitfield :name type-name
 145                              :actual-type (parse-type base-type)))
 146         (bit-floor 1))
 147     (dolist (pair values)
 148       ;; bit-floor rule: find the greatest single-bit int used so far,
 149       ;; and store its left-shift
 150       (destructuring-bind (symbol &optional
 151                            (value (prog1 bit-floor
 152                                     (setf bit-floor (ash bit-floor 1)))
 153                                   value-p))
 154           (ensure-list pair)
 155         (check-type symbol symbol)
 156         (when value-p
 157           (check-type value integer)
 158           (when (and (>= value bit-floor) (single-bit-p value))
 159             (setf bit-floor (ash value 1))))
 160         (if (gethash symbol (symbol-values type))
 161             (error "A foreign bitfield cannot contain duplicate symbols: ~S."
 162                    symbol)
 163             (setf (gethash symbol (symbol-values type)) value))
 164         (push symbol (gethash value (value-symbols type)))))
 165     type))
 166
 167 (defmacro defbitfield (name-and-options &body masks)
 168   "Define an foreign enumerated type."
 169   (discard-docstring masks)
 170   (destructuring-bind (name &optional (base-type :int))
 171       (ensure-list name-and-options)
 172     `(eval-when (:compile-toplevel :load-toplevel :execute)
 173        (notice-foreign-type
 174         ',name (make-foreign-bitfield ',name ',base-type ',masks)))))
 175
 176 (defun foreign-bitfield-symbol-list (bitfield-type)
 177   "Return a list of SYMBOLS defined in BITFIELD-TYPE."
 178   (hash-keys-to-list (symbol-values (parse-type bitfield-type))))
 179
 180 (defun %foreign-bitfield-value (type symbols)
 181   (reduce #'logior symbols
 182           :key (lambda (symbol)
 183                  (check-type symbol symbol)
 184                  (or (gethash symbol (symbol-values type))
 185                      (error "~S is not a valid symbol for bitfield type ~S."
 186                             symbol type)))))
 187
 188 (defun foreign-bitfield-value (type symbols)
 189   "Convert a list of symbols into an integer according to the TYPE bitfield."
 190   (let ((type-obj (parse-type type)))
 191     (if (not (typep type-obj 'foreign-bitfield))
 192       (error "~S is not a foreign bitfield type." type)
 193       (%foreign-bitfield-value type-obj symbols))))
 194
 195 (defun %foreign-bitfield-symbols (type value)
 196   (check-type value integer)
 197   (loop for mask being the hash-keys in (value-symbols type)
 198             using (hash-value symbols)
 199         when (= (logand value mask) mask)
 200         append symbols))
 201
 202 (defun foreign-bitfield-symbols (type value)
 203   "Convert an integer VALUE into a list of matching symbols according to
 204 the bitfield TYPE."
 205   (let ((type-obj (parse-type type)))
 206     (if (not (typep type-obj 'foreign-bitfield))
 207         (error "~S is not a foreign bitfield type." type)
 208         (%foreign-bitfield-symbols type-obj value))))
 209
 210 (defmethod translate-to-foreign (value (type foreign-bitfield))
 211   (if (integerp value)
 212       value
 213       (%foreign-bitfield-value type (ensure-list value))))
 214
 215 (defmethod translate-from-foreign (value (type foreign-bitfield))
 216   (%foreign-bitfield-symbols type value))