src/bits.lisp @ c689117887e3

(in-package :tdcb)

;;;; Struct -------------------------------------------------------------------
(defstruct (bits (:constructor make-bits% (underlying-stream))
                 (:conc-name nil))
  (underlying-stream nil :type stream :read-only t)
  (rack 0 :type (unsigned-byte 8))
  (mask #b10000000 :type (unsigned-byte 8)))

(declaim (inline write-bit% read-bit%))


;;;; Write --------------------------------------------------------------------
(defun write-bit% (b bit)
  (declare (type bits b))
  (when (plusp bit)
    (logiorf (rack b) (mask b)))
  (when (zerop (ashf (mask b) -1))
    (write-byte (rack b) (underlying-stream b))
    (setf (rack b) 0
          (mask b) #b10000000)))

(defun write-bit (b bit)
  (write-bit% b bit)
  bit)

(defun write-bits (b byte count)
  (loop :with mask = (ash 1 (1- count))
        :until (zerop mask)
        :do (progn (write-bit% b (logand mask byte))
                   (ashf mask -1)))
  byte)

(defun flush (b)
  (unless (= (mask b) #x80)
    (write-byte (rack b) (underlying-stream b))))


;;;; Read ---------------------------------------------------------------------
(defun read-bit% (b)
  (declare (type bits b))
  (when (= (mask b) #b10000000)
    (setf (rack b) (read-byte (underlying-stream b))))
  (prog1 (if (zerop (logand (mask b) (rack b)))
           0
           1)
    (when (zerop (ashf (mask b) -1))
      (setf (mask b) #b10000000))))

(defun read-bit (b)
  (read-bit% b))

(defun read-bits (b count)
  (loop :with result = 0
        :with mask = (ash 1 (1- count))
        :until (zerop mask)
        :do (progn (when (plusp (read-bit b))
                     (logiorf result mask))
                   (ashf mask -1))
        :finally (return result)))


;;;; Create -------------------------------------------------------------------
(defmacro with-bits-output ((var stream) &body body)
  `(let ((,var (make-bits% ,stream)))
     (unwind-protect (progn ,@body)
       (flush ,var))))

(defmacro with-bits-input ((var stream) &body body)
  `(let ((,var (make-bits% ,stream)))
     ,@body))