Coverage report: /home/luis/src/cffi/src/enum.lisp

KindCoveredAll%
expression96141 68.1
branch1030 33.3
Key
Not instrumented
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
 ;;;# Foreign Constants as Lisp Keywords
31
 ;;;
32
 ;;; This module defines the DEFCENUM macro, which provides an
33
 ;;; interface for defining a type and associating a set of integer
34
 ;;; constants with keyword symbols for that type.
35
 ;;;
36
 ;;; The keywords are automatically translated to the appropriate
37
 ;;; constant for the type by a type translator when passed as
38
 ;;; arguments or a return value to a foreign function.
39
 
40
 (defclass foreign-enum (foreign-typedef enhanced-foreign-type)
41
   ((keyword-values
42
     :initform (make-hash-table :test 'eq)
43
     :reader keyword-values)
44
    (value-keywords
45
     :initform (make-hash-table)
46
     :reader value-keywords))
47
   (:documentation "Describes a foreign enumerated type."))
48
 
49
 (defun make-foreign-enum (type-name base-type values)
50
   "Makes a new instance of the foreign-enum class."
51
   (let ((type (make-instance 'foreign-enum :name type-name
52
                              :actual-type (parse-type base-type)))
53
         (default-value 0))
54
     (dolist (pair values)
55
       (destructuring-bind (keyword &optional (value default-value))
56
           (ensure-list pair)
57
         (check-type keyword keyword)
58
         (check-type value integer)
59
         (if (gethash keyword (keyword-values type))
60
             (error "A foreign enum cannot contain duplicate keywords: ~S."
61
                    keyword)
62
             (setf (gethash keyword (keyword-values type)) value))
63
         ;; This completely arbitrary behaviour: we keep the last we
64
         ;; value->keyword mapping. I suppose the opposite would be just as
65
         ;; good (keeping the first). Returning a list with all the keywords
66
         ;; might be a solution too? Suggestions welcome. --luis
67
         (setf (gethash value (value-keywords type)) keyword)
68
         (setq default-value (1+ value))))
69
     type))
70
 
71
 (defmacro defcenum (name-and-options &body enum-list)
72
   "Define an foreign enumerated type."
73
   (discard-docstring enum-list)
74
   (destructuring-bind (name &optional (base-type :int))
75
       (ensure-list name-and-options)
76
     `(eval-when (:compile-toplevel :load-toplevel :execute)
77
        (notice-foreign-type
78
         ',name (make-foreign-enum ',name ',base-type ',enum-list)))))
79
 
80
 ;;; These [four] functions could be good canditates for compiler macros
81
 ;;; when the value or keyword is constant.  I am not going to bother
82
 ;;; until someone has a serious performance need to do so though. --jamesjb
83
 (defun %foreign-enum-value (type keyword &key errorp)
84
   (check-type keyword keyword)
85
   (or (gethash keyword (keyword-values type))
86
       (when errorp
87
         (error "~S is not defined as a keyword for enum type ~S."
88
                keyword type))))
89
 
90
 (defun foreign-enum-value (type keyword &key (errorp t))
91
   "Convert a KEYWORD into an integer according to the enum TYPE."
92
   (let ((type-obj (parse-type type)))
93
     (if (not (typep type-obj 'foreign-enum))
94
       (error "~S is not a foreign enum type." type)
95
       (%foreign-enum-value type-obj keyword :errorp errorp))))
96
 
97
 (defun %foreign-enum-keyword (type value &key errorp)
98
   (check-type value integer)
99
   (or (gethash value (value-keywords type))
100
       (when errorp
101
         (error "~S is not defined as a value for enum type ~S."
102
                value type))))
103
 
104
 (defun foreign-enum-keyword (type value &key (errorp t))
105
   "Convert an integer VALUE into a keyword according to the enum TYPE."
106
   (let ((type-obj (parse-type type)))
107
     (if (not (typep type-obj 'foreign-enum))
108
         (error "~S is not a foreign enum type." type)
109
         (%foreign-enum-keyword type-obj value :errorp errorp))))
110
 
111
 (defmethod translate-to-foreign (value (type foreign-enum))
112
   (if (keywordp value)
113
       (%foreign-enum-value type value :errorp t)
114
       value))
115
 
116
 (defmethod translate-from-foreign (value (type foreign-enum))
117
   (%foreign-enum-keyword type value :errorp t))
118
 
119
 ;;;# Foreign Bitfields as Lisp keywords
120
 ;;;
121
 ;;; DEFBITFIELD is an abstraction similar to the one provided by DEFCENUM.
122
 ;;; With some changes to DEFCENUM, this could certainly be implemented on
123
 ;;; top of it.
124
 
125
 (defclass foreign-bitfield (foreign-typedef enhanced-foreign-type)
126
   ((symbol-values
127
     :initform (make-hash-table :test 'eq)
128
     :reader symbol-values)
129
    (value-symbols
130
     :initform (make-hash-table)
131
     :reader value-symbols))
132
   (:documentation "Describes a foreign bitfield type."))
133
 
134
 (defun make-foreign-bitfield (type-name base-type values)
135
   "Makes a new instance of the foreign-bitfield class."
136
   (let ((type (make-instance 'foreign-bitfield :name type-name
137
                              :actual-type (parse-type base-type)))
138
         (bit-floor 1))
139
     (dolist (pair values)
140
       ;; bit-floor rule: find the greatest single-bit int used so far,
141
       ;; and store its left-shift
142
       (destructuring-bind (symbol &optional
143
                            (value (prog1 bit-floor
144
                                     (setf bit-floor (ash bit-floor 1)))
145
                                   value-p))
146
           (ensure-list pair)
147
         (check-type symbol symbol)
148
         (when value-p
149
           (check-type value integer)
150
           (when (and (>= value bit-floor) (single-bit-p value))
151
             (setf bit-floor (ash value 1))))
152
         (if (gethash symbol (symbol-values type))
153
             (error "A foreign bitfield cannot contain duplicate symbols: ~S."
154
                    symbol)
155
             (setf (gethash symbol (symbol-values type)) value))
156
         (push symbol (gethash value (value-symbols type)))))
157
     type))
158
 
159
 (defmacro defbitfield (name-and-options &body masks)
160
   "Define an foreign enumerated type."
161
   (discard-docstring masks)
162
   (destructuring-bind (name &optional (base-type :int))
163
       (ensure-list name-and-options)
164
     `(eval-when (:compile-toplevel :load-toplevel :execute)
165
        (notice-foreign-type
166
         ',name (make-foreign-bitfield ',name ',base-type ',masks)))))
167
 
168
 (defun %foreign-bitfield-value (type symbols)
169
   (reduce #'logior symbols
170
           :key (lambda (symbol)
171
                  (check-type symbol symbol)
172
                  (or (gethash symbol (symbol-values type))
173
                      (error "~S is not a valid symbol for bitfield type ~S."
174
                             symbol type)))))
175
 
176
 (defun foreign-bitfield-value (type symbols)
177
   "Convert a list of symbols into an integer according to the TYPE bitfield."
178
   (let ((type-obj (parse-type type)))
179
     (if (not (typep type-obj 'foreign-bitfield))
180
       (error "~S is not a foreign bitfield type." type)
181
       (%foreign-bitfield-value type-obj symbols))))
182
 
183
 (defun %foreign-bitfield-symbols (type value)
184
   (check-type value integer)
185
   (loop for mask being the hash-keys in (value-symbols type)
186
             using (hash-value symbols)
187
         when (= (logand value mask) mask)
188
         append symbols))
189
 
190
 (defun foreign-bitfield-symbols (type value)
191
   "Convert an integer VALUE into a list of matching symbols according to
192
 the bitfield TYPE."
193
   (let ((type-obj (parse-type type)))
194
     (if (not (typep type-obj 'foreign-bitfield))
195
         (error "~S is not a foreign bitfield type." type)
196
         (%foreign-bitfield-symbols type-obj value))))
197
 
198
 (defmethod translate-to-foreign (value (type foreign-bitfield))
199
   (if (integerp value)
200
       value
201
       (%foreign-bitfield-value type (ensure-list value))))
202
 
203
 (defmethod translate-from-foreign (value (type foreign-bitfield))
204
   (%foreign-bitfield-symbols type value))
205