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