1 ;;;; $Id: bitstream.lisp,v 1.12 2007/12/20 12:19:03 xach Exp $
5 (defun bitstream-callback-missing (&rest args
)
6 (declare (ignore args
))
7 (error "No callback set in bitstream"))
9 (defun merge-bits (code size buffer bits callback
)
10 (declare (type (unsigned-byte 32) code
)
11 (type (integer 0 32) size
)
12 (type bitstream-buffer-bit-count bits
)
13 (type bitstream-buffer buffer
)
14 (type function callback
)
16 ;; BITS represents how many bits have been added to BUFFER so far,
17 ;; so the FLOOR of it by 8 will give both the buffer byte index and
18 ;; the bit index within that byte to where new bits should be
20 (let ((buffer-index (ash bits -
3))
21 (bit (logand #b111 bits
)))
22 ;; The first byte to which new bits are merged might have some
23 ;; bits in it already, so pull it out for merging back in the
24 ;; loop. This only has to be done for the first byte, since
25 ;; subsequent bytes in the buffer will consist solely of bits from
28 ;; The check (PLUSP BIT) is done to make sure that no garbage bits
29 ;; from a previous write are re-used; if (PLUSP BIT) is zero, all
30 ;; bits in the first output byte come from CODE.
31 (let ((merge-byte (if (plusp bit
) (aref buffer buffer-index
) 0))
32 (end #.
+bitstream-buffer-size
+)
33 (result (+ bits size
)))
34 ;; (ceiling (+ bit size) 8) is the total number of bytes touched
36 (dotimes (i (ceiling (+ bit size
) 8))
37 (let ((shift (+ bit
(* i -
8)))
38 (j (+ buffer-index i
)))
39 ;; Buffer filled up in the middle of CODE
41 (funcall callback buffer j
))
42 ;; Merge part of CODE into the buffer
43 (setf (aref buffer
(logand #.
+bitstream-buffer-mask
+ j
))
44 (logior (logand #xFF
(ash code shift
)) merge-byte
))
46 ;; Writing is done, and the buffer is full, so call the callback
47 (when (= result
#.
+bitstream-buffer-bits
+)
48 (funcall callback buffer
#.
+bitstream-buffer-size
+))
49 ;; Return only the low bits of the sum
50 (logand #.
+bitstream-buffer-bitmask
+ result
))))
52 (defun merge-octet (octet buffer bits callback
)
53 (declare (type octet octet
)
54 (type bitstream-buffer buffer
)
55 (type bitstream-buffer-bit-count bits
)
56 (type function callback
)
58 (let ((offset (ceiling bits
8)))
59 ;; End of the buffer beforehand
60 (when (= offset
#.
+bitstream-buffer-size
+)
61 (funcall callback buffer
#.
+bitstream-buffer-size
+)
64 (setf (aref buffer offset
) octet
66 (when (= (1+ offset
) #.
+bitstream-buffer-size
+)
67 (funcall callback buffer
#.
+bitstream-buffer-size
+)
73 (defclass bitstream
()
77 :documentation
"Holds accumulated bits packed into octets.")
81 :documentation
"The number of bits written to the buffer so far.")
85 :documentation
"A function of two arguments, BUFFER and END,
86 that should write out all the data in BUFFER up to END."))
88 :buffer
(make-array +bitstream-buffer-size
+ :element-type
'octet
)
90 :callback
#'bitstream-callback-missing
))
92 (defgeneric write-bits
(code size bitstream
))
93 (defgeneric write-octet
(octet bitstream
))
94 (defgeneric write-octet-vector
(vector bitstream
&key start end
))
95 (defgeneric flush
(bitstream))
97 (defmethod write-bits (code size
(bitstream bitstream
))
98 (setf (bits bitstream
)
102 (callback bitstream
))))
104 (defmethod write-octet (octet (bitstream bitstream
))
105 (setf (bits bitstream
)
109 (callback bitstream
))))
111 (defmethod write-octet-vector (vector (bitstream bitstream
) &key
(start 0) end
)
112 ;;; Not efficient in the slightest, but not actually used internally.
113 (let ((end (or end
(length vector
))))
114 (loop for i from start below end
115 do
(write-octet (aref vector i
) bitstream
))))
117 (defmethod flush ((bitstream bitstream
))
118 (let ((end (ceiling (bits bitstream
) 8)))
119 (funcall (callback bitstream
) (buffer bitstream
) end
)
120 (setf (bits bitstream
) 0)))