;;;; 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-))) ,@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 ,@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))))
(defpackage :bitstream (:use :cl)) (in-package :bitstream) #| An output bitstream. The idea here is that there are three-ish values important when writing n bit chunks to a stream. - a byte, acting as a buffer, accumulating the bits being written - a counter to indicate when the byte buffer is full - a stream to which full bytes are written However, you can store the first two in a single unsigned 16-bit value. Then you can store the 16-bit value and the stream in a cons. An empty byte buffer has the value #x00FF. Bits are added to the buffer by doing a LOGAND with a left shift. When the highest bit is set, the byte is written out and reset. The number of bits written to the byte buffer so far is: (logcount (logand #xFF00 buffer)) To finish writing a partially filled buffer, you can AND the high bits with the low bits to get the proper value: (logand (ldb (byte 8 8) buffer) (ldb (byte 8 0) buffer)) FWIW, I don't know if this arrangement of the buffer is actually clever or useful. I spent a lot of time staring at the disassembly, so maybe it fried my brain. |# (defun make-output-bitstream (stream &key (current-byte 0) (bits-left 8)) (assert (output-stream-p stream)) (assert (subtypep (stream-element-type stream) '(unsigned-byte 8))) (cons stream (logior current-byte (ash #xFF (- 8 bits-left))))) (declaim (inline iostream)) (defun iostream (bitstream) (car bitstream)) (declaim (inline buffer)) (defun buffer (bitstream) (the (unsigned-byte 16) (cdr bitstream))) (declaim (inline (setf buffer))) (defun (setf buffer) (new-value bitstream) (declare (type (unsigned-byte 16) new-value)) (setf (cdr bitstream) new-value)) (declaim (inline write-bit)) (defun write-bit (bit bitstream) "Write the single BIT to BITSTREAM." (declare (bit bit) (optimize (speed 3) (safety 0))) (let ((n (buffer bitstream))) (cond ((logtest (ash 1 15) n) (write-byte (logand #xFF n) (iostream bitstream)) (setf (buffer bitstream) (logior (ash #x00FF 1) bit))) (t (setf (buffer bitstream) (logior (ash n 1) bit)))))) (defun write-bits (integer width bitstream) "Write the leftmost WIDTH bits of INTEGER to BITSTREAM." (declare (integer integer) (type (unsigned-byte 29) width) (optimize (speed 3) (safety 0))) (when (minusp integer) (setf integer (ldb (byte width 0) integer))) (loop for i downfrom (1- width) to 0 do (write-bit (ldb (byte 1 i) integer) bitstream))) (defun finish-write (bitstream) (declare (optimize (speed 3) (safety 0))) (let* ((n (buffer bitstream)) (final-byte (logand (ldb (byte 8 8) n) (ldb (byte 8 0) n)))) (write-byte final-byte (iostream bitstream)) (setf (buffer bitstream) #xFF00))) (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 ,@body) (finish-write ,bitstream))))) (defun test-packed (file count value width) (with-open-file (stream file :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (with-output-bitstream (bitstream stream) (dotimes (i count) (write-bits value width bitstream)))))
participants (1)
-
Zach Beane