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