enum.lisp - clic - Clic is an command line interactive client for gopher writte… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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 <[email protected]> | |
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… | |
122 base-type type-name +valid-enum-base-types+)) | |
123 ;; details: https://stackoverflow.com/questions/1122096/what-is-… | |
124 (let ((bits (integer-length most-extreme-value))) | |
125 (setf base-type | |
126 (let ((most-uint-bits (load-time-value (* (foreign-… | |
127 (most-ulong-bits (load-time-value (* (foreign-… | |
128 (most-ulonglong-bits (load-time-value (* (foreign-… | |
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 s… | |
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… | |
171 ;; define it when we're being loaded from … | |
172 (,type-factory ',name ',base-type ',enum-l… | |
173 ,@(remove nil | |
174 (mapcar (lambda (key) | |
175 (unless (keywordp key) | |
176 `(defconstant ,key ,(foreign-enum-value t… | |
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. --jame… | |
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-… | |
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-FO… | |
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 DEFCENU… | |
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 bitfi… | |
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)))) |