[Small-cl-src] Re: bit I/O

[Zach Beane]

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