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 ;; TODO the accessors names are rather inconsistent:
  31 ;; FOREIGN-ENUM-VALUE           FOREIGN-BITFIELD-VALUE
  32 ;; FOREIGN-ENUM-KEYWORD         FOREIGN-BITFIELD-SYMBOLS
  33 ;; FOREIGN-ENUM-KEYWORD-LIST    FOREIGN-BITFIELD-SYMBOL-LIST
  34 ;; I'd rename them to: FOREIGN-*-KEY(S) and FOREIGN-*-ALL-KEYS -- attila
  35
  36 ;; TODO bitfield is a confusing name, because the C standard calls
  37 ;; the "int foo : 3" type as a bitfield. Maybe rename to defbitmask?
  38 ;; -- attila
  39
  40 ;;;# Foreign Constants as Lisp Keywords
  41 ;;;
  42 ;;; This module defines the DEFCENUM macro, which provides an
  43 ;;; interface for defining a type and associating a set of integer
  44 ;;; constants with keyword symbols for that type.
  45 ;;;
  46 ;;; The keywords are automatically translated to the appropriate
  47 ;;; constant for the type by a type translator when passed as
  48 ;;; arguments or a return value to a foreign function.
  49
  50 (defclass foreign-enum (named-foreign-type enhanced-foreign-type)
  51   ((keyword-values
  52     :initform (error "Must specify KEYWORD-VALUES.")
  53     :initarg :keyword-values
  54     :reader keyword-values)
  55    (value-keywords
  56     :initform (error "Must specify VALUE-KEYWORDS.")
  57     :initarg :value-keywords
  58     :reader value-keywords)
  59    (allow-undeclared-values
  60     :initform nil
  61     :initarg :allow-undeclared-values
  62     :reader allow-undeclared-values))
  63   (:documentation "Describes a foreign enumerated type."))
  64
  65 (deftype enum-key ()
  66   '(and symbol (not null)))
  67
  68 (defparameter +valid-enum-base-types+ *built-in-integer-types*)
  69
  70 (defun parse-foreign-enum-like (type-name base-type values
  71                                 &optional field-mode-p)
  72   (let ((keyword-values (make-hash-table :test 'eq))
  73         (value-keywords (make-hash-table))
  74         (field-keywords (list))
  75         (bit-index->keyword (make-array 0 :adjustable t
  76                                         :element-type t))
  77         (default-value (if field-mode-p 1 0))
  78         (most-extreme-value 0)
  79         (has-negative-value? nil))
  80     (dolist (pair values)
  81       (destructuring-bind (keyword &optional (value default-value valuep))
  82           (ensure-list pair)
  83         (check-type keyword enum-key)
  84         ;;(check-type value integer)
  85         (when (> (abs value) (abs most-extreme-value))
  86           (setf most-extreme-value value))
  87         (when (minusp value)
  88           (setf has-negative-value? t))
  89         (if field-mode-p
  90             (if valuep
  91                 (when (and (>= value default-value)
  92                            (single-bit-p value))
  93                   (setf default-value (ash value 1)))
  94                 (setf default-value (ash default-value 1)))
  95             (setf default-value (1+ value)))
  96         (if (gethash keyword keyword-values)
  97             (error "A foreign enum cannot contain duplicate keywords: ~S."
  98                    keyword)
  99             (setf (gethash keyword keyword-values) value))
 100         ;; This is completely arbitrary behaviour: we keep the last
 101         ;; value->keyword mapping. I suppose the opposite would be
 102         ;; just as good (keeping the first). Returning a list with all
 103         ;; the keywords might be a solution too? Suggestions
 104         ;; welcome. --luis
 105         (setf (gethash value value-keywords) keyword)
 106         (when (and field-mode-p
 107                    (single-bit-p value))
 108           (let ((bit-index (1- (integer-length value))))
 109             (push keyword field-keywords)
 110             (when (<= (array-dimension bit-index->keyword 0)
 111                       bit-index)
 112               (setf bit-index->keyword
 113                     (adjust-array bit-index->keyword (1+ bit-index)
 114                                   :initial-element nil)))
 115             (setf (aref bit-index->keyword bit-index)
 116                   keyword)))))
 117     (if base-type
 118         (progn
 119           (setf base-type (canonicalize-foreign-type base-type))
 120           ;; I guess we don't lose much by not strictly adhering to
 121           ;; the C standard here, and some libs out in the wild are
 122           ;; already using e.g. :double.
 123           #+nil
 124           (assert (member base-type +valid-enum-base-types+ :test 'eq) ()
 125                   "Invalid base type ~S for enum type ~S. Must be one of ~S."
 126                   base-type type-name +valid-enum-base-types+))
 127         ;; details: https://stackoverflow.com/questions/1122096/what-is-the-underlying-type-of-a-c-enum
 128         (let ((bits (integer-length most-extreme-value)))
 129           (setf base-type
 130                 (let ((most-uint-bits      (load-time-value (* (foreign-type-size :unsigned-int) 8)))
 131                       (most-ulong-bits     (load-time-value (* (foreign-type-size :unsigned-long) 8)))
 132                       (most-ulonglong-bits (load-time-value (* (foreign-type-size :unsigned-long-long) 8))))
 133                   (or (if has-negative-value?
 134                           (cond
 135                             ((<= (1+ bits) most-uint-bits)
 136                              :int)
 137                             ((<= (1+ bits) most-ulong-bits)
 138                              :long)
 139                             ((<= (1+ bits) most-ulonglong-bits)
 140                              :long-long))
 141                           (cond
 142                             ((<= bits most-uint-bits)
 143                              :unsigned-int)
 144                             ((<= bits most-ulong-bits)
 145                              :unsigned-long)
 146                             ((<= bits most-ulonglong-bits)
 147                              :unsigned-long-long)))
 148                       (error "Enum value ~S of enum ~S is too large to store."
 149                              most-extreme-value type-name))))))
 150     (values base-type keyword-values value-keywords
 151             field-keywords (when field-mode-p
 152                              (alexandria:copy-array
 153                               bit-index->keyword :adjustable nil
 154                               :fill-pointer nil)))))
 155
 156 (defun make-foreign-enum (type-name base-type values &key allow-undeclared-values)
 157   "Makes a new instance of the foreign-enum class."
 158   (multiple-value-bind
 159         (base-type keyword-values value-keywords)
 160       (parse-foreign-enum-like type-name base-type values)
 161     (make-instance 'foreign-enum
 162                    :name type-name
 163                    :actual-type (parse-type base-type)
 164                    :keyword-values keyword-values
 165                    :value-keywords value-keywords
 166                    :allow-undeclared-values allow-undeclared-values)))
 167
 168 (defun %defcenum-like (name-and-options enum-list type-factory)
 169   (discard-docstring enum-list)
 170   (destructuring-bind (name &optional base-type &rest args)
 171       (ensure-list name-and-options)
 172     (let ((type (apply type-factory name base-type enum-list args)))
 173       `(eval-when (:compile-toplevel :load-toplevel :execute)
 174          (notice-foreign-type ',name
 175                               ;; ,type is not enough here, someone needs to
 176                               ;; define it when we're being loaded from a fasl.
 177                               (,type-factory ',name ',base-type ',enum-list ,@args))
 178          ,@(remove nil
 179                    (mapcar (lambda (key)
 180                              (unless (keywordp key)
 181                                `(defconstant ,key ,(foreign-enum-value type key))))
 182                            (foreign-enum-keyword-list type)))))))
 183
 184 (defmacro defcenum (name-and-options &body enum-list)
 185   "Define an foreign enumerated type."
 186   (%defcenum-like name-and-options enum-list 'make-foreign-enum))
 187
 188 (defun hash-keys-to-list (ht)
 189   (loop for k being the hash-keys in ht collect k))
 190
 191 (defun foreign-enum-keyword-list (enum-type)
 192   "Return a list of KEYWORDS defined in ENUM-TYPE."
 193   (hash-keys-to-list (keyword-values (ensure-parsed-base-type enum-type))))
 194
 195 ;;; These [four] functions could be good canditates for compiler macros
 196 ;;; when the value or keyword is constant.  I am not going to bother
 197 ;;; until someone has a serious performance need to do so though. --jamesjb
 198 (define-compiler-macro %foreign-enum-value (&whole whole
 199                                             type keyword &key errorp)
 200   (if (constantp keyword)
 201       (let ((v (eval keyword)))
 202         (if (typep v 'enum-key)
 203             (foreign-enum-value type v :errorp errorp)
 204             v))
 205       whole))
 206
 207 (defun %foreign-enum-value (type keyword &key errorp)
 208   (check-type keyword enum-key)
 209   (or (gethash keyword (keyword-values type))
 210       (when errorp
 211         (error "~S is not defined as a keyword for enum type ~S."
 212                keyword type))))
 213
 214 (defun foreign-enum-value (type keyword &key (errorp t))
 215   "Convert a KEYWORD into an integer according to the enum TYPE."
 216   (let ((type-obj (ensure-parsed-base-type type)))
 217     (if (not (typep type-obj 'foreign-enum))
 218       (error "~S is not a foreign enum type." type)
 219       (%foreign-enum-value type-obj keyword :errorp errorp))))
 220
 221 (defun %foreign-enum-keyword (type value &key errorp)
 222   (check-type value integer)
 223   (or (gethash value (value-keywords type))
 224       (when errorp
 225         (error "~S is not defined as a value for enum type ~S."
 226                value type))))
 227
 228 (defun foreign-enum-keyword (type value &key (errorp t))
 229   "Convert an integer VALUE into a keyword according to the enum TYPE."
 230   (let ((type-obj (ensure-parsed-base-type type)))
 231     (if (not (typep type-obj 'foreign-enum))
 232         (error "~S is not a foreign enum type." type)
 233         (%foreign-enum-keyword type-obj value :errorp errorp))))
 234
 235 (defmethod translate-to-foreign (value (type foreign-enum))
 236   (if (typep value 'enum-key)
 237       (%foreign-enum-value type value :errorp t)
 238       value))
 239
 240 (defmethod translate-into-foreign-memory
 241     (value (type foreign-enum) pointer)
 242   (setf (mem-aref pointer (unparse-type (actual-type type)))
 243         (translate-to-foreign value type)))
 244
 245 (defmethod translate-from-foreign (value (type foreign-enum))
 246   (if (allow-undeclared-values type)
 247       (or (%foreign-enum-keyword type value :errorp nil)
 248           value)
 249       (%foreign-enum-keyword type value :errorp t)))
 250
 251 (defmethod expand-to-foreign (value (type foreign-enum))
 252   ;; once-only prevents compiler macro on %foreign-enum-value, so
 253   ;; expand constant values here too
 254   (if (constantp value)
 255       (let ((v (eval value)))
 256         (if (typep v 'enum-key)
 257             (%foreign-enum-value type v :errorp t)
 258             v))
 259       (once-only (value)
 260         `(if (typep ,value 'enum-key)
 261              (%foreign-enum-value ,type ,value :errorp t)
 262              ,value))))
 263
 264 ;;; There are two expansions necessary for an enum: first, the enum
 265 ;;; keyword needs to be translated to an int, and then the int needs
 266 ;;; to be made indirect.
 267 (defmethod expand-to-foreign-dyn-indirect (value var body (type foreign-enum))
 268   (expand-to-foreign-dyn-indirect       ; Make the integer indirect
 269    (with-unique-names (feint)
 270      (call-next-method value feint (list feint) type)) ; TRANSLATABLE-FOREIGN-TYPE method
 271    var
 272    body
 273    (actual-type type)))
 274
 275 ;;;# Foreign Bitfields as Lisp keywords
 276 ;;;
 277 ;;; DEFBITFIELD is an abstraction similar to the one provided by DEFCENUM.
 278 ;;; With some changes to DEFCENUM, this could certainly be implemented on
 279 ;;; top of it.
 280
 281 (defclass foreign-bitfield (foreign-enum)
 282   ((field-keywords
 283     :initform (error "Must specify FIELD-KEYWORDS.")
 284     :initarg :field-keywords
 285     :reader field-keywords)
 286    (bit-index->keyword
 287     :initform (error "Must specify BIT-INDEX->KEYWORD")
 288     :initarg :bit-index->keyword
 289     :reader bit-index->keyword))
 290   (:documentation "Describes a foreign bitfield type."))
 291
 292 (defun make-foreign-bitfield (type-name base-type values)
 293   "Makes a new instance of the foreign-bitfield class."
 294   (multiple-value-bind
 295         (base-type keyword-values value-keywords
 296                    field-keywords bit-index->keyword)
 297       (parse-foreign-enum-like type-name base-type values t)
 298     (make-instance 'foreign-bitfield
 299                    :name type-name
 300                    :actual-type (parse-type base-type)
 301                    :keyword-values keyword-values
 302                    :value-keywords value-keywords
 303                    :field-keywords field-keywords
 304                    :bit-index->keyword bit-index->keyword)))
 305
 306 (defmacro defbitfield (name-and-options &body masks)
 307   "Define an foreign enumerated type."
 308   (%defcenum-like name-and-options masks 'make-foreign-bitfield))
 309
 310 (defun foreign-bitfield-symbol-list (bitfield-type)
 311   "Return a list of SYMBOLS defined in BITFIELD-TYPE."
 312   (field-keywords (ensure-parsed-base-type bitfield-type)))
 313
 314 (defun %foreign-bitfield-value (type symbols)
 315   (declare (optimize speed))
 316   (labels ((process-one (symbol)
 317              (check-type symbol symbol)
 318              (or (gethash symbol (keyword-values type))
 319                  (error "~S is not a valid symbol for bitfield type ~S."
 320                         symbol type))))
 321     (declare (dynamic-extent #'process-one))
 322     (cond
 323       ((consp symbols)
 324        (reduce #'logior symbols :key #'process-one))
 325       ((null symbols)
 326        0)
 327       (t
 328        (process-one symbols)))))
 329
 330 (defun foreign-bitfield-value (type symbols)
 331   "Convert a list of symbols into an integer according to the TYPE bitfield."
 332   (let ((type-obj (ensure-parsed-base-type type)))
 333     (assert (typep type-obj 'foreign-bitfield) ()
 334             "~S is not a foreign bitfield type." type)
 335     (%foreign-bitfield-value type-obj symbols)))
 336
 337 (define-compiler-macro foreign-bitfield-value (&whole form type symbols)
 338   "Optimize for when TYPE and SYMBOLS are constant."
 339   (declare (notinline foreign-bitfield-value))
 340   (if (and (constantp type) (constantp symbols))
 341       (foreign-bitfield-value (eval type) (eval symbols))
 342       form))
 343
 344 (defun %foreign-bitfield-symbols (type value)
 345   (check-type value integer)
 346   (check-type type foreign-bitfield)
 347   (loop
 348     :with bit-index->keyword = (bit-index->keyword type)
 349     :for bit-index :from 0 :below (array-dimension bit-index->keyword 0)
 350     :for mask = 1 :then (ash mask 1)
 351     :for key = (aref bit-index->keyword bit-index)
 352     :when (and key
 353                (= (logand value mask) mask))
 354     :collect key))
 355
 356 (defun foreign-bitfield-symbols (type value)
 357   "Convert an integer VALUE into a list of matching symbols according to
 358 the bitfield TYPE."
 359   (let ((type-obj (ensure-parsed-base-type type)))
 360     (if (not (typep type-obj 'foreign-bitfield))
 361         (error "~S is not a foreign bitfield type." type)
 362         (%foreign-bitfield-symbols type-obj value))))
 363
 364 (define-compiler-macro foreign-bitfield-symbols (&whole form type value)
 365   "Optimize for when TYPE and SYMBOLS are constant."
 366   (declare (notinline foreign-bitfield-symbols))
 367   (if (and (constantp type) (constantp value))
 368       `(quote ,(foreign-bitfield-symbols (eval type) (eval value)))
 369       form))
 370
 371 (defmethod translate-to-foreign (value (type foreign-bitfield))
 372   (if (integerp value)
 373       value
 374       (%foreign-bitfield-value type (ensure-list value))))
 375
 376 (defmethod translate-from-foreign (value (type foreign-bitfield))
 377   (%foreign-bitfield-symbols type value))
 378
 379 (defmethod expand-to-foreign (value (type foreign-bitfield))
 380   (flet ((expander (value type)
 381            `(if (integerp ,value)
 382                 ,value
 383                 (%foreign-bitfield-value ,type (ensure-list ,value)))))
 384     (if (constantp value)
 385         (eval (expander value type))
 386         (expander value type))))
 387
 388 (defmethod expand-from-foreign (value (type foreign-bitfield))
 389   (flet ((expander (value type)
 390            `(%foreign-bitfield-symbols ,type ,value)))
 391     (if (constantp value)
 392         (eval (expander value type))
 393         (expander value type))))