Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 281 lines (268 sloc) 11.13 kB
3cda291 @froydnj add skeleton sources and vector reffing
authored
1 ;;;; vectors.lisp -- signed/unsigned byte accessors
2
3 (cl:in-package :nibbles)
4
4aea424 @froydnj add ARRAY-DATA-AND-OFFSETS
authored
5 (declaim (inline array-data-and-offsets))
6 (defun array-data-and-offsets (v start end)
7 "Like ARRAY-DISPLACEMENT, only more useful."
8 #+sbcl
9 (sb-kernel:with-array-data ((v v) (start start) (end end))
10 (values v start end))
11 #+cmu
12 (lisp::with-array-data ((v v) (start start) (end end))
13 (values v start end))
14 #-(or sbcl cmu)
15 (values v start (or end (length v))))
16
0b2d08b @froydnj optimize full-call refs and sets for SBCL
authored
17 (eval-when (:compile-toplevel :execute)
18 (defun ref-form (vector-name index-name byte-size signedp big-endian-p)
19 "Return a form that fetches a SIGNEDP BYTE-SIZE value from VECTOR-NAME,
20 starting at INDEX-NAME. The value is stored in the vector according to
21 BIG-ENDIAN-P."
22 (multiple-value-bind (low high increment compare)
23 (if big-endian-p
24 (values 0 (1- byte-size) 1 #'>)
25 (values (1- byte-size) 0 -1 #'<))
26 (do ((i (+ low increment) (+ i increment))
27 (shift (* (- byte-size 2) 8) (- shift 8))
28 (forms nil))
29 ((funcall compare i high)
30 `(let* ((high-byte (aref , vector-name
31 (+ ,index-name ,low)))
32 ;; Would be great if we could just sign-extend along
33 ;; with the load, but this is as good as it gets in
34 ;; portable Common Lisp.
35 (signed-high ,(if signedp
36 `(if (logbitp 7 high-byte)
37 (- high-byte 256)
38 high-byte)
39 'high-byte))
40 (shifted-into-place
41 (ash signed-high ,(* (1- byte-size) 8))))
42 (declare (type (unsigned-byte 8) high-byte))
43 (declare (type (,(if signedp 'signed-byte 'unsigned-byte) 8)
44 signed-high))
45 (logior shifted-into-place ,@(nreverse forms))))
46 (push `(ash (aref ,vector-name
47 (+ ,index-name ,i))
48 ,shift)
49 forms))))
50 (defun set-form (vector-name index-name value-name byte-size big-endian-p)
51 "Return a form that stores a BYTE-SIZE VALUE-NAME into VECTOR-NAME,
52 starting at INDEX-NAME. The value is stored in the vector according to
53 BIG-ENDIAN-P. The form returns VALUE-NAME."
54 `(progn
55 ,@(loop for i from 1 to byte-size
56 collect (let ((offset (if big-endian-p
57 (- byte-size i)
58 (1- i))))
59 `(setf (aref ,vector-name
60 (+ ,index-name ,offset))
61 (ldb (byte 8 ,(* 8 (1- i))) ,value-name))))
62 ,value-name))
63 ) ; EVAL-WHEN
64
3cda291 @froydnj add skeleton sources and vector reffing
authored
65 (macrolet ((define-fetcher (bitsize signedp big-endian-p)
bb0eb47 @froydnj use DEFSETF for defining SETF functions
authored
66 (let ((ref-name (byte-ref-fun-name bitsize signedp big-endian-p))
3cda291 @froydnj add skeleton sources and vector reffing
authored
67 (bytes (truncate bitsize 8)))
6caf614 @froydnj tweak function argument names for better documentation
authored
68 `(defun ,ref-name (vector index)
69 (declare (type octet-vector vector))
48dda02 @froydnj use ARRAY-DATA-AND-OFFSETS to generalize reffers and setters
authored
70 (declare (type (integer 0 ,(- array-dimension-limit bytes)) index))
71 (multiple-value-bind (vector start end)
6caf614 @froydnj tweak function argument names for better documentation
authored
72 (array-data-and-offsets vector index (+ index ,bytes))
0b2d08b @froydnj optimize full-call refs and sets for SBCL
authored
73 #+sbcl (declare (optimize (sb-c::insert-array-bounds-checks 0)))
74 (declare (type (integer 0 ,(- array-dimension-limit bytes)) start))
48dda02 @froydnj use ARRAY-DATA-AND-OFFSETS to generalize reffers and setters
authored
75 (declare (ignore end))
0b2d08b @froydnj optimize full-call refs and sets for SBCL
authored
76 ,(ref-form 'vector 'start bytes signedp big-endian-p)))))
3cda291 @froydnj add skeleton sources and vector reffing
authored
77 (define-storer (bitsize signedp big-endian-p)
bb0eb47 @froydnj use DEFSETF for defining SETF functions
authored
78 (let ((ref-name (byte-ref-fun-name bitsize signedp big-endian-p))
79 (set-name (byte-set-fun-name bitsize signedp big-endian-p))
3cda291 @froydnj add skeleton sources and vector reffing
authored
80 (bytes (truncate bitsize 8)))
81 `(progn
6caf614 @froydnj tweak function argument names for better documentation
authored
82 (defun ,set-name (vector index value)
83 (declare (type octet-vector vector))
3cda291 @froydnj add skeleton sources and vector reffing
authored
84 (declare (type (integer 0 ,(- array-dimension-limit bytes)) index))
be0f88d @froydnj fix signed setter bug promptly caught by new tests
authored
85 (declare (type (,(if signedp
86 'signed-byte
87 'unsigned-byte) ,bitsize) value))
48dda02 @froydnj use ARRAY-DATA-AND-OFFSETS to generalize reffers and setters
authored
88 (multiple-value-bind (vector start end)
6caf614 @froydnj tweak function argument names for better documentation
authored
89 (array-data-and-offsets vector index (+ index ,bytes))
0b2d08b @froydnj optimize full-call refs and sets for SBCL
authored
90 #+sbcl (declare (optimize (sb-c::insert-array-bounds-checks 0)))
91 (declare (type (integer 0 ,(- array-dimension-limit bytes)) start))
48dda02 @froydnj use ARRAY-DATA-AND-OFFSETS to generalize reffers and setters
authored
92 (declare (ignore end))
0b2d08b @froydnj optimize full-call refs and sets for SBCL
authored
93 ,(set-form 'vector 'start 'value bytes big-endian-p)))
bb0eb47 @froydnj use DEFSETF for defining SETF functions
authored
94 (defsetf ,ref-name ,set-name))))
3cda291 @froydnj add skeleton sources and vector reffing
authored
95 (define-fetchers-and-storers (bitsize)
96 (loop for i from 0 below 4
97 for signedp = (logbitp 1 i)
98 for big-endian-p = (logbitp 0 i)
99 collect `(define-fetcher ,bitsize ,signedp ,big-endian-p) into forms
100 collect `(define-storer ,bitsize ,signedp ,big-endian-p) into forms
101 finally (return `(progn ,@forms)))))
102 (define-fetchers-and-storers 16)
103 (define-fetchers-and-storers 32)
104 (define-fetchers-and-storers 64))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
105
106 (defun not-supported ()
107 (error "not supported"))
108
6caf614 @froydnj tweak function argument names for better documentation
authored
109 (defun ieee-single-ref/be (vector index)
110 (declare (ignorable vector index))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
111 #+sbcl
6caf614 @froydnj tweak function argument names for better documentation
authored
112 (sb-kernel:make-single-float (sb32ref/be vector index))
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
113 #+cmu
6caf614 @froydnj tweak function argument names for better documentation
authored
114 (kernel:make-single-float (sb32ref/be vector index))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
115 #+ccl
6caf614 @froydnj tweak function argument names for better documentation
authored
116 (ccl::host-single-float-from-unsigned-byte-32 (ub32ref/be vector index))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
117 #+allegro
6caf614 @froydnj tweak function argument names for better documentation
authored
118 (let ((b (ub32ref/be vector index)))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
119 (excl:shorts-to-single-float (ldb (byte 16 16) b) (ldb (byte 16 0) b)))
d28a22f @froydnj add single-float reffers and setters for Lispworks
authored
120 #+lispworks
6caf614 @froydnj tweak function argument names for better documentation
authored
121 (let* ((ub (ub32ref/be vector index))
d28a22f @froydnj add single-float reffers and setters for Lispworks
authored
122 (v (sys:make-typed-aref-vector 4)))
123 (declare (optimize (speed 3) (float 0) (safety 0)))
124 (declare (dynamic-extent v))
125 (setf (sys:typed-aref '(unsigned-byte 32) v 0) ub)
126 (sys:typed-aref 'single-float v 0))
127 #-(or sbcl cmu ccl allegro lispworks)
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
128 (not-supported))
129
6caf614 @froydnj tweak function argument names for better documentation
authored
130 (defun (setf ieee-single-ref/be) (value vector index)
131 (declare (ignorable value vector index))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
132 #+sbcl
133 (progn
6caf614 @froydnj tweak function argument names for better documentation
authored
134 (setf (sb32ref/be vector index) (sb-kernel:single-float-bits value))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
135 value)
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
136 #+cmu
137 (progn
6caf614 @froydnj tweak function argument names for better documentation
authored
138 (setf (sb32ref/be vector index) (kernel:single-float-bits value))
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
139 value)
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
140 #+ccl
141 (progn
6caf614 @froydnj tweak function argument names for better documentation
authored
142 (setf (ub32ref/be vector index) (ccl::single-float-bits value))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
143 value)
144 #+allegro
145 (multiple-value-bind (hi lo) (excl:single-float-to-shorts value)
6caf614 @froydnj tweak function argument names for better documentation
authored
146 (setf (ub16ref/be vector index) hi
147 (ub16ref/be vector (+ index 2) lo))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
148 value)
d28a22f @froydnj add single-float reffers and setters for Lispworks
authored
149 #+lispworks
150 (let* ((v (sys:make-typed-aref-vector 4)))
151 (declare (optimize (speed 3) (float 0) (safety 0)))
152 (declare (dynamic-extent v))
153 (setf (sys:typed-aref 'single-float v 0) value)
6caf614 @froydnj tweak function argument names for better documentation
authored
154 (setf (ub32ref/be vector index) (sys:typed-aref '(unsigned-byte 32) v 0))
d28a22f @froydnj add single-float reffers and setters for Lispworks
authored
155 value)
156 #-(or sbcl cmu ccl allegro lispworks)
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
157 (not-supported))
158
6caf614 @froydnj tweak function argument names for better documentation
authored
159 (defun ieee-single-ref/le (vector index)
160 (declare (ignorable vector index))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
161 #+sbcl
6caf614 @froydnj tweak function argument names for better documentation
authored
162 (sb-kernel:make-single-float (sb32ref/le vector index))
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
163 #+cmu
6caf614 @froydnj tweak function argument names for better documentation
authored
164 (kernel:make-single-float (sb32ref/le vector index))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
165 #+ccl
6caf614 @froydnj tweak function argument names for better documentation
authored
166 (ccl::host-single-float-from-unsigned-byte-32 (ub32ref/le vector index))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
167 #+allegro
6caf614 @froydnj tweak function argument names for better documentation
authored
168 (let ((b (ub32ref/le vector index)))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
169 (excl:shorts-to-single-float (ldb (byte 16 16) b) (ldb (byte 16 0) b)))
d28a22f @froydnj add single-float reffers and setters for Lispworks
authored
170 #+lispworks
6caf614 @froydnj tweak function argument names for better documentation
authored
171 (let* ((ub (ub32ref/le vector index))
d28a22f @froydnj add single-float reffers and setters for Lispworks
authored
172 (v (sys:make-typed-aref-vector 4)))
173 (declare (optimize (speed 3) (float 0) (safety 0)))
174 (declare (dynamic-extent v))
175 (setf (sys:typed-aref '(unsigned-byte 32) v 0) ub)
176 (sys:typed-aref 'single-float v 0))
177 #-(or sbcl cmu ccl allegro lispworks)
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
178 (not-supported))
179
6caf614 @froydnj tweak function argument names for better documentation
authored
180 (defun (setf ieee-single-ref/le) (value vector index)
181 (declare (ignorable value vector index))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
182 #+sbcl
183 (progn
6caf614 @froydnj tweak function argument names for better documentation
authored
184 (setf (sb32ref/le vector index) (sb-kernel:single-float-bits value))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
185 value)
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
186 #+cmu
187 (progn
6caf614 @froydnj tweak function argument names for better documentation
authored
188 (setf (sb32ref/le vector index) (kernel:single-float-bits value))
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
189 value)
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
190 #+ccl
191 (progn
6caf614 @froydnj tweak function argument names for better documentation
authored
192 (setf (ub32ref/le vector index) (ccl::single-float-bits value))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
193 value)
194 #+allegro
195 (multiple-value-bind (hi lo) (excl:single-float-to-shorts value)
6caf614 @froydnj tweak function argument names for better documentation
authored
196 (setf (ub16ref/le vector (+ index 2)) hi
197 (ub16ref/le vector index lo))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
198 value)
d28a22f @froydnj add single-float reffers and setters for Lispworks
authored
199 #+lispworks
200 (let* ((v (sys:make-typed-aref-vector 4)))
201 (declare (optimize (speed 3) (float 0) (safety 0)))
202 (declare (dynamic-extent v))
203 (setf (sys:typed-aref 'single-float v 0) value)
6caf614 @froydnj tweak function argument names for better documentation
authored
204 (setf (ub32ref/le vector index) (sys:typed-aref '(unsigned-byte 32) v 0))
d28a22f @froydnj add single-float reffers and setters for Lispworks
authored
205 value)
206 #-(or sbcl cmu ccl allegro lispworks)
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
207 (not-supported))
208
6caf614 @froydnj tweak function argument names for better documentation
authored
209 (defun ieee-double-ref/be (vector index)
210 (declare (ignorable vector index))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
211 #+sbcl
6caf614 @froydnj tweak function argument names for better documentation
authored
212 (let ((upper (sb32ref/be vector index))
213 (lower (ub32ref/be vector (+ index 4))))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
214 (sb-kernel:make-double-float upper lower))
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
215 #+cmu
6caf614 @froydnj tweak function argument names for better documentation
authored
216 (let ((upper (sb32ref/be vector index))
217 (lower (ub32ref/be vector (+ index 4))))
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
218 (kernel:make-double-float upper lower))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
219 #+ccl
6caf614 @froydnj tweak function argument names for better documentation
authored
220 (let ((upper (ub32ref/be vector index))
221 (lower (ub32ref/be vector (+ index 4))))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
222 (ccl::make-double-float-from-bits upper lower))
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
223 #-(or sbcl cmu ccl)
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
224 (not-supported))
225
6caf614 @froydnj tweak function argument names for better documentation
authored
226 (defun (setf ieee-double-ref/be) (value vector index)
227 (declare (ignorable value vector index))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
228 #+sbcl
229 (progn
6caf614 @froydnj tweak function argument names for better documentation
authored
230 (setf (sb32ref/be vector index) (sb-kernel:double-float-high-bits value)
231 (ub32ref/be vector (+ index 4)) (sb-kernel:double-float-low-bits value))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
232 value)
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
233 #+cmu
234 (progn
6caf614 @froydnj tweak function argument names for better documentation
authored
235 (setf (sb32ref/be vector index) (kernel:double-float-high-bits value)
236 (ub32ref/be vector (+ index 4)) (kernel:double-float-low-bits value))
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
237 value)
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
238 #+ccl
239 (multiple-value-bind (upper lower) (ccl::double-float-bits value)
6caf614 @froydnj tweak function argument names for better documentation
authored
240 (setf (ub32ref/be vector index) upper
241 (ub32ref/be vector (+ index 4)) lower)
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
242 value)
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
243 #-(or sbcl cmu ccl)
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
244 (not-supported))
245
6caf614 @froydnj tweak function argument names for better documentation
authored
246 (defun ieee-double-ref/le (vector index)
247 (declare (ignorable vector index))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
248 #+sbcl
6caf614 @froydnj tweak function argument names for better documentation
authored
249 (let ((upper (sb32ref/le vector (+ index 4)))
250 (lower (ub32ref/le vector index)))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
251 (sb-kernel:make-double-float upper lower))
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
252 #+cmu
6caf614 @froydnj tweak function argument names for better documentation
authored
253 (let ((upper (sb32ref/le vector (+ index 4)))
254 (lower (ub32ref/le vector index)))
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
255 (kernel:make-double-float upper lower))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
256 #+ccl
6caf614 @froydnj tweak function argument names for better documentation
authored
257 (let ((upper (ub32ref/le vector (+ index 4)))
258 (lower (ub32ref/le vector index)))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
259 (ccl::make-double-float-from-bits upper lower))
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
260 #-(or sbcl cmu ccl)
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
261 (not-supported))
262
6caf614 @froydnj tweak function argument names for better documentation
authored
263 (defun (setf ieee-double-ref/le) (value vector index)
264 (declare (ignorable value vector index))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
265 #+sbcl
266 (progn
6caf614 @froydnj tweak function argument names for better documentation
authored
267 (setf (sb32ref/le vector (+ index 4)) (sb-kernel:double-float-high-bits value)
268 (ub32ref/le vector index) (sb-kernel:double-float-low-bits value))
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
269 value)
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
270 #+cmu
271 (progn
6caf614 @froydnj tweak function argument names for better documentation
authored
272 (setf (sb32ref/le vector (+ index 4)) (kernel:double-float-high-bits value)
273 (ub32ref/le vector index) (kernel:double-float-low-bits value))
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
274 value)
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
275 #+ccl
276 (multiple-value-bind (upper lower) (ccl::double-float-bits value)
6caf614 @froydnj tweak function argument names for better documentation
authored
277 (setf (ub32ref/le vector (+ index 4)) upper
278 (ub32ref/le vector index) lower)
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
279 value)
2405f3b @froydnj add #+cmu cases for float reffers and setters
authored
280 #-(or sbcl cmu ccl)
5382220 @froydnj add read/write single/double floats from/to octet vectors
authored
281 (not-supported))
Something went wrong with that request. Please try again.