Coverage report: /home/ellis/.stash/quicklisp/dists/quicklisp/software/cffi-20250622-git/src/enum.lisp

KindCoveredAll%
expression0462 0.0
branch074 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
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))))