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(defun %foreign-enum-value (type keyword &key errorp) 199 (check-type keyword enum-key) 200 (or (gethash keyword (keyword-values type)) 201 (when errorp 202 (error "~S is not defined as a keyword for enum type ~S." 203 keyword type)))) 204 205(defun foreign-enum-value (type keyword &key (errorp t)) 206 "Convert a KEYWORD into an integer according to the enum TYPE." 207 (let ((type-obj (ensure-parsed-base-type type))) 208 (if (not (typep type-obj 'foreign-enum)) 209 (error "~S is not a foreign enum type." type) 210 (%foreign-enum-value type-obj keyword :errorp errorp)))) 211 212(defun %foreign-enum-keyword (type value &key errorp) 213 (check-type value integer) 214 (or (gethash value (value-keywords type)) 215 (when errorp 216 (error "~S is not defined as a value for enum type ~S." 217 value type)))) 218 219(defun foreign-enum-keyword (type value &key (errorp t)) 220 "Convert an integer VALUE into a keyword according to the enum TYPE." 221 (let ((type-obj (ensure-parsed-base-type type))) 222 (if (not (typep type-obj 'foreign-enum)) 223 (error "~S is not a foreign enum type." type) 224 (%foreign-enum-keyword type-obj value :errorp errorp)))) 225 226(defmethod translate-to-foreign (value (type foreign-enum)) 227 (if (typep value 'enum-key) 228 (%foreign-enum-value type value :errorp t) 229 value)) 230 231(defmethod translate-into-foreign-memory 232 (value (type foreign-enum) pointer) 233 (setf (mem-aref pointer (unparse-type (actual-type type))) 234 (translate-to-foreign value type))) 235 236(defmethod translate-from-foreign (value (type foreign-enum)) 237 (if (allow-undeclared-values type) 238 (or (%foreign-enum-keyword type value :errorp nil) 239 value) 240 (%foreign-enum-keyword type value :errorp t))) 241 242(defmethod expand-to-foreign (value (type foreign-enum)) 243 (once-only (value) 244 `(if (typep ,value 'enum-key) 245 (%foreign-enum-value ,type ,value :errorp t) 246 ,value))) 247 248;;; There are two expansions necessary for an enum: first, the enum 249;;; keyword needs to be translated to an int, and then the int needs 250;;; to be made indirect. 251(defmethod expand-to-foreign-dyn-indirect (value var body (type foreign-enum)) 252 (expand-to-foreign-dyn-indirect ; Make the integer indirect 253 (with-unique-names (feint) 254 (call-next-method value feint (list feint) type)) ; TRANSLATABLE-FOREIGN-TYPE method 255 var 256 body 257 (actual-type type))) 258 259;;;# Foreign Bitfields as Lisp keywords 260;;; 261;;; DEFBITFIELD is an abstraction similar to the one provided by DEFCENUM. 262;;; With some changes to DEFCENUM, this could certainly be implemented on 263;;; top of it. 264 265(defclass foreign-bitfield (foreign-enum) 266 ((field-keywords 267 :initform (error "Must specify FIELD-KEYWORDS.") 268 :initarg :field-keywords 269 :reader field-keywords) 270 (bit-index->keyword 271 :initform (error "Must specify BIT-INDEX->KEYWORD") 272 :initarg :bit-index->keyword 273 :reader bit-index->keyword)) 274 (:documentation "Describes a foreign bitfield type.")) 275 276(defun make-foreign-bitfield (type-name base-type values) 277 "Makes a new instance of the foreign-bitfield class." 278 (multiple-value-bind 279 (base-type keyword-values value-keywords 280 field-keywords bit-index->keyword) 281 (parse-foreign-enum-like type-name base-type values t) 282 (make-instance 'foreign-bitfield 283 :name type-name 284 :actual-type (parse-type base-type) 285 :keyword-values keyword-values 286 :value-keywords value-keywords 287 :field-keywords field-keywords 288 :bit-index->keyword bit-index->keyword))) 289 290(defmacro defbitfield (name-and-options &body masks) 291 "Define an foreign enumerated type." 292 (%defcenum-like name-and-options masks 'make-foreign-bitfield)) 293 294(defun foreign-bitfield-symbol-list (bitfield-type) 295 "Return a list of SYMBOLS defined in BITFIELD-TYPE." 296 (field-keywords (ensure-parsed-base-type bitfield-type))) 297 298(defun %foreign-bitfield-value (type symbols) 299 (declare (optimize speed)) 300 (labels ((process-one (symbol) 301 (check-type symbol symbol) 302 (or (gethash symbol (keyword-values type)) 303 (error "~S is not a valid symbol for bitfield type ~S." 304 symbol type)))) 305 (declare (dynamic-extent #'process-one)) 306 (cond 307 ((consp symbols) 308 (reduce #'logior symbols :key #'process-one)) 309 ((null symbols) 310 0) 311 (t 312 (process-one symbols))))) 313 314(defun foreign-bitfield-value (type symbols) 315 "Convert a list of symbols into an integer according to the TYPE bitfield." 316 (let ((type-obj (ensure-parsed-base-type type))) 317 (assert (typep type-obj 'foreign-bitfield) () 318 "~S is not a foreign bitfield type." type) 319 (%foreign-bitfield-value type-obj symbols))) 320 321(define-compiler-macro foreign-bitfield-value (&whole form type symbols) 322 "Optimize for when TYPE and SYMBOLS are constant." 323 (declare (notinline foreign-bitfield-value)) 324 (if (and (constantp type) (constantp symbols)) 325 (foreign-bitfield-value (eval type) (eval symbols)) 326 form)) 327 328(defun %foreign-bitfield-symbols (type value) 329 (check-type value integer) 330 (check-type type foreign-bitfield) 331 (loop 332 :with bit-index->keyword = (bit-index->keyword type) 333 :for bit-index :from 0 :below (array-dimension bit-index->keyword 0) 334 :for mask = 1 :then (ash mask 1) 335 :for key = (aref bit-index->keyword bit-index) 336 :when (and key 337 (= (logand value mask) mask)) 338 :collect key)) 339 340(defun foreign-bitfield-symbols (type value) 341 "Convert an integer VALUE into a list of matching symbols according to 342the bitfield TYPE." 343 (let ((type-obj (ensure-parsed-base-type type))) 344 (if (not (typep type-obj 'foreign-bitfield)) 345 (error "~S is not a foreign bitfield type." type) 346 (%foreign-bitfield-symbols type-obj value)))) 347 348(define-compiler-macro foreign-bitfield-symbols (&whole form type value) 349 "Optimize for when TYPE and SYMBOLS are constant." 350 (declare (notinline foreign-bitfield-symbols)) 351 (if (and (constantp type) (constantp value)) 352 `(quote ,(foreign-bitfield-symbols (eval type) (eval value))) 353 form)) 354 355(defmethod translate-to-foreign (value (type foreign-bitfield)) 356 (if (integerp value) 357 value 358 (%foreign-bitfield-value type (ensure-list value)))) 359 360(defmethod translate-from-foreign (value (type foreign-bitfield)) 361 (%foreign-bitfield-symbols type value)) 362 363(defmethod expand-to-foreign (value (type foreign-bitfield)) 364 (flet ((expander (value type) 365 `(if (integerp ,value) 366 ,value 367 (%foreign-bitfield-value ,type (ensure-list ,value))))) 368 (if (constantp value) 369 (eval (expander value type)) 370 (expander value type)))) 371 372(defmethod expand-from-foreign (value (type foreign-bitfield)) 373 (flet ((expander (value type) 374 `(%foreign-bitfield-symbols ,type ,value))) 375 (if (constantp value) 376 (eval (expander value type)) 377 (expander value type)))) 378