/[cmucl]/src/code/stream-vector-io.lisp
ViewVC logotype

Contents of /src/code/stream-vector-io.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (show annotations)
Tue Apr 20 17:57:45 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.8: +3 -3 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Package: Lisp -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/stream-vector-io.lisp,v 1.9 2010/04/20 17:57:45 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Stream I/O for vectors
13 ;;; Written by Lynn Quam
14 ;;;
15
16 (in-package "EXT")
17
18 (intl:textdomain "cmucl")
19
20 (export '(read-vector write-vector))
21
22 ;;; READ-VECTOR WRITE-VECTOR
23
24 (declaim (start-block read-vector write-vector))
25
26 ;;; ENDIAN SWAPPING
27
28 ;;; Not sure that this is really need, but for completeness ...
29 (defun swap-endians-456 (vector start end endian)
30 (declare (optimize (speed 3)(safety 0)))
31 (declare (type kernel:simple-stream-buffer vector))
32 (declare (fixnum start end endian))
33 (loop for i fixnum from (* 8 start) below (* 8 end) by 8
34 for b0 fixnum = (bref vector i)
35 for b1 fixnum = (bref vector (+ i 1))
36 for b2 fixnum = (bref vector (+ i 2))
37 for b3 fixnum = (bref vector (+ i 3))
38 for b4 fixnum = (bref vector (+ i 4))
39 for b5 fixnum = (bref vector (+ i 5))
40 for b6 fixnum = (bref vector (+ i 6))
41 for b7 fixnum = (bref vector (+ i 7))
42 do (setf (bref vector (logxor i endian)) b0)
43 (setf (bref vector (logxor (+ i 1) endian)) b1)
44 (setf (bref vector (logxor (+ i 2) endian)) b2)
45 (setf (bref vector (logxor (+ i 3) endian)) b3)
46 (setf (bref vector (logxor (+ i 4) endian)) b4)
47 (setf (bref vector (logxor (+ i 5) endian)) b5)
48 (setf (bref vector (logxor (+ i 6) endian)) b6)
49 (setf (bref vector (logxor (+ i 7) endian)) b7)
50 ))
51 ;(disassemble 'endian-swap-vector)
52 (defun endian-swap-vector (vector start end endian-swap)
53 (declare (optimize (speed 3)(safety 0)))
54 (declare (type simple-array vector))
55 (declare (fixnum start end endian-swap ))
56 (unless (eql endian-swap 0)
57 (when (>= endian-swap (vector-elt-width vector))
58 (error (intl:gettext "endian-swap ~a is illegal for element-type of vector ~a")
59 endian-swap vector))
60 (lisp::with-array-data ((data vector) (offset-start start)
61 (offset-end end))
62 ;;(declare (type (kernel:simple-unboxed-array (*)) data))
63 (macrolet ((swap8 (i j)
64 `(rotatef (bref data ,i) (bref data ,j))))
65 (case endian-swap
66 (1 (loop for i fixnum from (* 2 start) below (* 2 end) by 2
67 do (swap8 i (+ i 1))))
68 (3 (loop for i fixnum from (* 4 start) below (* 4 end) by 4
69 do (swap8 i (+ i 3))
70 (swap8 (+ i 1) (+ i 2))))
71 (7 (loop for i fixnum from (* 8 start) below (* 8 end) by 8
72 do (swap8 i (+ i 7))
73 (swap8 (+ i 1) (+ i 6))
74 (swap8 (+ i 2) (+ i 5))
75 (swap8 (+ i 3) (+ i 4))))
76 (2 (loop with sap = (sys:vector-sap vector)
77 for i fixnum from (* 2 start) below (* 2 end) by 2
78 do (rotatef (sys:sap-ref-16 sap i) (sys:sap-ref-16
79 sap (+ i 1)))))
80 ;; Not sure that swap-endians-456
81 ((4 5 6) (swap-endians-456 data offset-start offset-end
82 endian-swap))
83 (-1
84 ;; Swap nibbles
85 ;;
86 ;; NOTE: start and end are in terms of elements (4 bits)
87 ;; but we want octets in this loop.
88 (let ((start-octet (truncate start 2))
89 (end-octet (truncate end 2)))
90 (loop for i fixnum from start-octet below end-octet
91 do
92 (let ((x (bref data i)))
93 (setf (bref data i) (logior (ash (logand x #x0f) 4)
94 (ash (logand x #xf0) -4)))))))
95 (-2
96 ;; Swap pairs of bits.
97 (let ((start-octet (truncate start 4))
98 (end-octet (truncate end 4)))
99 (loop for i fixnum from start-octet below end-octet
100 do
101 (let ((x (bref data i)))
102 (declare (type (unsigned-byte 8) x))
103 (setf x (logior (ash (logand x #x33) 2)
104 (ash (logand x #xcc) -2)))
105 (setf x (logior (ash (logand x #x0f) 4)
106 (ash (logand x #xf0) -4)))
107 (setf (bref data i) x)))))
108 (-8
109 ;; Swap bits
110 (let ((start-octet (truncate start 8))
111 (end-octet (truncate end 8)))
112 (loop for i fixnum from start-octet below end-octet
113 do
114 (let ((x (bref data i)))
115 (declare (type (unsigned-byte 8) x))
116 (setf x (logior (ash (logand x #x55) 1)
117 (ash (logand x #xaa) -1)))
118 (setf x (logior (ash (logand x #x33) 2)
119 (ash (logand x #xcc) -2)))
120 (setf x (logior (ash (logand x #x0f) 4)
121 (ash (logand x #xf0) -4)))
122 (setf (bref data i) x)))))
123 ;;otherwise, do nothing ???
124 )))))
125
126 (deftype simple-numeric-vector ()
127 `(or (simple-array bit (*))
128 (simple-array (unsigned-byte 2) (*))
129 (simple-array (unsigned-byte 4) (*))
130 (simple-array (unsigned-byte 8) (*))
131 (simple-array (signed-byte 8) (*))
132 (simple-array (unsigned-byte 16) (*))
133 (simple-array (signed-byte 16) (*))
134 (simple-array (unsigned-byte 32) (*))
135 (simple-array (signed-byte 32) (*))
136 (simple-array (unsigned-byte *) (*))
137 (simple-array (signed-byte *) (*))
138 (simple-array single-float (*))
139 (simple-array double-float (*))))
140
141 ;; Read from stream into vector. Start and End are byte offsets into
142 ;; the vector.
143 (defun read-vector* (vector stream start end)
144 (labels ((get-n-bytes (stream data offset numbytes)
145 ;; Handle case of read-n-bytes reading short.
146 (let ((need numbytes))
147 (loop
148 (let ((n (read-n-bytes stream data offset need nil)))
149 (decf need n)
150 (cond ((or (zerop need) ; Complete
151 (zerop n)) ; EOF
152 (return (- numbytes need)))
153 (t (incf offset n)))))))
154 (read-n-x8-bytes (stream data offset-start offset-end)
155 (let* ((numbytes (- offset-end offset-start))
156 (bytes-read (get-n-bytes
157 stream
158 data
159 offset-start
160 numbytes)))
161 (if (< bytes-read numbytes)
162 (+ offset-start bytes-read)
163 offset-end))))
164 (read-n-x8-bytes stream vector start end)))
165
166 ;;; New versions of READ-VECTOR and WRITE-VECTOR that deal with octet positions
167 ;;; rather than element-positions, for compatibility with Allegro.
168
169 ;;; WARNING: START and END must be a multiple of octets-per-element.
170 ;;; For element types smaller than 8 bits, START and END are octet
171 ;;; indices, so you cannot read into arbitrary positions of the
172 ;;; vector.
173 ;;;
174 ;;; (Should we enforce this constraint?)
175 ;;;
176
177 ;;; READ-VECTOR --
178 (defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8))
179 "Read from Stream into Vector. The Start and End indices of Vector
180 is in octets, and must be an multiple of the octets per element of
181 the vector element. The keyword argument :Endian-Swap specifies any
182 endian swapping to be done. "
183 (declare (type vector vector)
184 (type stream stream)
185 (type unsigned-byte start) ; a list does not have a limit
186 (type (or null unsigned-byte) end)
187 (values unsigned-byte))
188 ;;(declare (optimize (speed 3)(safety 0)))
189 ;; START and END are octet offsets, not vector indices! [Except for strings]
190 ;; Return value is index of next octet to be read into (i.e., start+count)
191
192 (unless (typep vector '(or string simple-numeric-vector))
193 (error (intl:gettext "Wrong vector type ~a for read-vector on stream ~a.") (type-of vector) stream))
194 (let* ((octets-per-element (vector-elt-width vector))
195 (start-elt (truncate start octets-per-element))
196 (end-octet (or end (ceiling (* (length vector) octets-per-element))))
197 (end-elt (if end
198 (truncate end octets-per-element)
199 (length vector)))
200 (next-index (read-vector* vector stream
201 start
202 end-octet)))
203 (endian-swap-vector vector start-elt end-elt
204 (endian-swap-value vector endian-swap))
205 next-index))
206
207 ;; Write vector into stream. Start and End are byte offsets into the
208 ;; vector.
209 (declaim (inline write-vector*))
210 (defun write-vector* (vector stream start end)
211 (system:output-raw-bytes stream vector start end))
212
213 ;;; WRITE VECTOR --
214 ;;; returns the next octet-position in vector.
215 (defun write-vector (vector stream &key (start 0) (end nil) (endian-swap :byte-8))
216 "Write Vector to Stream. The Start and End indices of Vector is in
217 octets, and must be an multiple of the octets per element of the
218 vector element. The keyword argument :Endian-Swap specifies any
219 endian swapping to be done. "
220 (declare (type vector vector)
221 (type stream stream)
222 (type unsigned-byte start) ; a list does not have a limit
223 (type (or null unsigned-byte) end)
224 (values unsigned-byte))
225
226 (let* ((octets-per-element (vector-elt-width vector))
227 (start-elt (truncate start octets-per-element))
228 (end-octet (or end (ceiling (* (length vector) octets-per-element))))
229 (end-elt (if end
230 (truncate end octets-per-element)
231 (length vector)))
232 (swap-mask (endian-swap-value vector endian-swap))
233 (next-index end-octet))
234 (declare (type fixnum swap-mask next-index))
235 (cond ((= swap-mask 0)
236 (write-vector* vector stream start end-octet))
237 (t
238 ;; In a multiprocessing situation, WITHOUT-INTERRUPTS might be required here
239 ;; otherwise the vector could be seen by another process in the modified state.
240 (unless (typep vector '(or string simple-numeric-vector))
241 (error "Wrong vector type ~a for write-vector on stream ~a." (type-of vector)
242 stream))
243 (endian-swap-vector vector start-elt end-elt swap-mask)
244 (unwind-protect
245 (write-vector* vector stream start end-octet)
246 (endian-swap-vector vector start-elt end-elt swap-mask))
247 vector))
248 next-index))
249
250
251 (declaim (end-block)) ; READ-VECTOR WRITE-VECTOR block

  ViewVC Help
Powered by ViewVC 1.1.5