[Small-cl-src] bit I/O
Zach Beane
xach at xach.com
Fri Jul 9 16:47:59 UTC 2004
;;;; The following stuff is taken, verbatim and somewhat unpolished,
;;;; from something I'm currently working on.
;;;;
;;;; Bit-level I/O. The Flash spec has various structures packed into
;;;; bit fields.
;;;;
;;;; $Id: bitio.lisp,v 1.5 2004/07/08 02:47:20 xach Exp $
(in-package :flash)
(defclass bitstream ()
((current-byte :initarg :current-byte :accessor current-byte)
(bits-left :initarg :bits-left :accessor bits-left)
(stream :initarg :stream :reader stream))
(:documentation
"A class for writing or reading bits to or from an (UNSIGNED-BYTE 8) stream."))
;;; Input
(defun make-input-bitstream (stream &key (current-byte 0) (bits-left 0))
"Return a bitstream suitable for reading. The CURRENT-BYTE and
BITS-LEFT, if specified, initialize the internal byte buffer and
count."
(assert (input-stream-p stream))
(assert (subtypep (stream-element-type stream) '(unsigned-byte 8)))
(make-instance 'bitstream
:stream stream
:current-byte current-byte
:bits-left bits-left))
(defmethod read-bits (width (bitstream bitstream) &optional (signedp nil))
(with-accessors ((bits-left bits-left) (input stream)
(current-byte current-byte))
bitstream
(loop with result = 0
with bits-needed = width
while (plusp bits-needed)
if (> bits-needed bits-left) do
(setf result (logior (ash result bits-left)
(ldb (byte bits-left 0) current-byte))
bits-needed (- bits-needed bits-left)
current-byte (read-byte input)
bits-left 8)
else do
(setf result (logior (ash result bits-needed)
(ldb (byte bits-needed (- bits-left
bits-needed))
current-byte))
bits-left (- bits-left bits-needed)
bits-needed 0)
finally (if (and signedp
(logbitp (1- width) result))
(return (1- (- (logandc2 (1- (ash 1 width)) result))))
(return result)))))
(defmethod read-boolean ((bitstream bitstream))
"Read and return a single bit from BITSTREAM as a boolean."
(logbitp 0 (read-bits 1 bitstream)))
(defmacro with-input-bitstream ((bitstream stream
&key (current-byte 0) (bits-left 0))
&body body)
"Evaluate BODY with a newly-created input bitstream bound to BITSTREAM."
(let ((-current-byte- (gensym))
(-bits-left- (gensym)))
`(let* ((,-current-byte- ,current-byte)
(,-bits-left- ,bits-left)
(,bitstream (make-input-bitstream ,stream
:current-byte ,-current-byte-
:bits-left ,-bits-left-)))
, at body)))
;;; Output
(defun make-output-bitstream (stream &key (current-byte 0) (bits-left 8))
"Return a bitstream suitable for writing. The CURRENT-BYTE and
BITS-LEFT, if specified, initialize the internal byte buffer and
count."
(assert (output-stream-p stream))
(assert (subtypep (stream-element-type stream) '(unsigned-byte 8)))
(make-instance 'bitstream
:stream stream
:current-byte current-byte
:bits-left bits-left))
(defmethod write-bits (integer width (bitstream bitstream))
"Write the rightmost WIDTH bits from INTEGER to the bitstream"
(with-accessors ((bits-left bits-left) (stream stream)
(current-byte current-byte))
bitstream
(when (minusp integer)
(setf integer (ldb (byte width 0) integer)))
(loop with bits-needed = width
while (plusp bits-needed)
if (> bits-needed bits-left) do
(setf (ldb (byte bits-left 0) current-byte)
(ldb (byte bits-left (- bits-needed bits-left)) integer)
bits-needed (- bits-needed bits-left))
(write-byte current-byte stream)
(setf current-byte 0
bits-left 8)
else do
(setf (ldb (byte bits-needed (- bits-left bits-needed)) current-byte)
(ldb (byte bits-needed 0) integer)
bits-left (- bits-left bits-needed)
bits-needed 0))))
(defmethod write-bit (bit (bitstream bitstream))
"Write a single bit to the bitstream."
(write-bits bit 1 bitstream))
(defmethod write-boolean (boolean (bitstream bitstream))
"Write BOOLEAN as a bit to the bitstream."
(if boolean
(write-bit 1 bitstream)
(write-bit 0 bitstream)))
(defmethod finish-write ((bitstream bitstream))
"Flush the output buffer byte of BITSTREAM. Uninitialized bits are
written as 0."
(when (< (bits-left bitstream) 8)
(write-byte (current-byte bitstream) (stream bitstream))
(setf (current-byte bitstream) 0)
(setf (bits-left bitstream) 8)))
(defmacro with-output-bitstream ((bitstream stream
&key (current-byte 0) (bits-left 8))
&body body)
"Evaluate BODY with a newly-created output bitstream bound to
BITSTREAM. Pending output is flushed at the end of evaluation."
(let ((-current-byte- (gensym))
(-bits-left- (gensym)))
`(let* ((,-current-byte- ,current-byte)
(,-bits-left- ,bits-left)
(,bitstream (make-output-bitstream ,stream
:current-byte ,-current-byte-
:bits-left ,-bits-left-)))
(unwind-protect
(progn , at body)
(finish-write ,bitstream)))))
(defun test-bitstreams (file width integer)
(with-open-file (output file :direction :output
:element-type '(unsigned-byte 8)
:if-exists :supersede
:if-does-not-exist :create)
(with-output-bitstream (bitstream output)
(write-bits integer width bitstream)))
(with-open-file (input file :direction :input
:element-type '(unsigned-byte 8))
(with-input-bitstream (bitstream input)
(list (read-bits width bitstream t) integer))))
;;; Utility
(defun sufficient-bits (&rest numbers)
"Return the number of bits necessary to represent the largest number
in NUMBERS."
(loop for number in numbers
maximizing (1+ (integer-length number))))
More information about the Small-cl-src
mailing list