(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)))))