binary-types.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 1999-2004,
   4 ;;;;    Department of Computer Science, University of Tromsoe, Norway
   5 ;;;;
   6 ;;;; Filename:      binary-types.lisp
   7 ;;;; Description:   Reading and writing of binary data in streams.
   8 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
   9 ;;;; Created at:    Fri Nov 19 18:53:57 1999
  10 ;;;; Distribution:  See the accompanying file COPYING.
  11 ;;;;
  12 ;;;; $Id: binary-types.lisp,v 1.3 2004/04/20 08:32:50 ffjeld Exp $
  13 ;;;;
  14 ;;;;------------------------------------------------------------------
  15
  16 (defpackage #:binary-types
  17   (:nicknames #:bt)
  18   (:use #:common-lisp)
  19   (:export #:*endian*                   ; [dynamic-var] must be bound when reading integers
  20            #:endianess                  ; [deftype] The set of endian names
  21            ;; built-in types
  22            #:char8                      ; [type-name] 8-bit character
  23            #:u8                         ; [type-name] 8-bit unsigned integer
  24            #:u16                        ; [type-name] 16-bit unsigned integer
  25            #:u32                        ; [type-name] 32-bit unsigned integer
  26            #:s8                         ; [type-name] 8-bit signed integer
  27            #:s16                        ; [type-name] 16-bit signed integer
  28            #:s32                        ; [type-name] 32-bit signed integer
  29                                         ; (you may define additional integer types
  30                                         ; of any size yourself.)
  31            ;; type defining macros
  32            #:define-unsigned            ; [macro] declare an unsigned-int type
  33            #:define-signed              ; [macro] declare a signed-int type
  34            #:define-binary-struct       ; [macro] declare a binary defstruct type
  35            #:define-binary-class        ; [macro] declare a binary defclass type
  36            #:define-bitfield            ; [macro] declare a bitfield (symbolic integer) type
  37            #:define-enum                ; [macro] declare an enumerated type
  38            #:define-binary-string       ; [macro] declare a string type
  39            #:define-null-terminated-string ; [macro] declare a null-terminated string
  40            ;; readers and writers
  41            #:read-binary                ; [func] reads a binary-type from a stream
  42            #:read-binary-record         ; [method]
  43            #:write-binary               ; [func] writes an binary object to a stream
  44            #:write-binary-record        ; [method]
  45            #:read-binary-string
  46            ;; record handling
  47            #:binary-record-slot-names   ; [func] list names of binary slots.
  48            #:binary-slot-value          ; [func] get "binary" version of slot's value
  49            #:binary-slot-type           ; [func] get binary slot's binary type
  50            #:binary-slot-tags           ; [func] get the tags of a binary slot
  51            #:slot-offset                ; [func] determine offset of slot.
  52            ;; misc
  53            #:find-binary-type           ; [func] accessor to binary-types namespace
  54            #:sizeof                     ; [func] The size in octets of a binary type
  55            #:enum-value                 ; [func] Calculate numeric version of enum value
  56            #:enum-symbolic-value        ; [func] Inverse of enum-value.
  57            #:with-binary-file           ; [macro] variant of with-open-file
  58            #:with-binary-output-to-list ; [macro]
  59            #:with-binary-output-to-vector ; [macro]
  60            #:with-binary-input-from-list ; [macro]
  61            #:with-binary-input-from-vector ; [macro]
  62            #:*binary-write-byte*        ; [dynamic-var]
  63            #:*binary-read-byte*         ; [dynamic-var]
  64            #:*padding-byte*             ; [dynamic-var] The value filled in when writing paddings
  65            #:split-bytes                ; [func] utility
  66            #:merge-bytes                ; [func] utility
  67            ))
  68
  69 (in-package binary-types)
  70
  71 (defvar *ignore-hidden-slots-for-pcl* nil
  72   "Really ugly hack to allow older PCL-infested lisps to work in the
  73 precense of :map-binary-read-delayed.")
  74
  75 (defvar *binary-write-byte* #'common-lisp:write-byte
  76   "The low-level WRITE-BYTE function used by binary-types.")
  77 (defvar *binary-read-byte*  #'common-lisp:read-byte
  78   "The low-level READ-BYTE function used by binary-types.")
  79
  80 ;;; ----------------------------------------------------------------
  81 ;;;                         Utilities
  82 ;;; ----------------------------------------------------------------
  83
  84 (defun make-pairs (list)
  85   "(make-pairs '(1 2 3 4)) => ((1 . 2) (3 . 4))"
  86   (loop for x on list by #'cddr collect (cons (first x) (second x))))
  87
  88 ;;; ----------------------------------------------------------------
  89 ;;;
  90 ;;; ----------------------------------------------------------------
  91
  92 (eval-when (:compile-toplevel :load-toplevel :execute)
  93   (deftype endianess ()
  94     "These are the legal declarations of endianess. The value NIL
  95 means that the endianess is determined by the dynamic value of *endian*."
  96     '(member nil :big-endian :little-endian)))
  97
  98 (defvar *endian* nil
  99   "*endian* must be (dynamically) bound to either :big-endian or
 100 :little-endian while reading endian-sensitive types.")
 101
 102 ;;; ----------------------------------------------------------------
 103 ;;;                  Binary Types Namespace
 104 ;;; ----------------------------------------------------------------
 105
 106 (defvar *binary-type-namespace* (make-hash-table :test #'eq)
 107   "Maps binary type's names (which are symbols) to their binary-type class object.")
 108
 109 (defun find-binary-type (name &optional (errorp t))
 110   (or (gethash name *binary-type-namespace*)
 111       (if errorp
 112           (error "Unable to find binary type named ~S." name)
 113         nil)))
 114
 115 (defun (setf find-binary-type) (value name)
 116   (check-type value binary-type)
 117   (let ((old-value (find-binary-type name nil)))
 118     (when (and old-value (not (eq (class-of value) (class-of old-value))))
 119       (warn "Redefining binary-type ~A from ~A to ~A."
 120             name (type-of old-value) (type-of value))))
 121   (setf (gethash name *binary-type-namespace*) value))
 122
 123 (defun find-binary-type-name (type)
 124   (maphash #'(lambda (key val)
 125                (when (eq type val)
 126                  (return-from find-binary-type-name key)))
 127            *binary-type-namespace*))
 128
 129 ;;; ----------------------------------------------------------------
 130 ;;;                  Base Binary Type (Abstract)
 131 ;;; ----------------------------------------------------------------
 132
 133 (defgeneric sizeof (type)
 134   (:documentation "Return the size in octets of the single argument TYPE,
 135 or nil if TYPE is not constant-sized."))
 136
 137 (defmethod sizeof (obj)
 138   (sizeof (find-binary-type (type-of obj))))
 139
 140 (defmethod sizeof ((type symbol))
 141   (sizeof (find-binary-type type)))
 142
 143 (defgeneric read-binary (type stream &key &allow-other-keys)
 144   (:documentation "Read an object of binary TYPE from STREAM."))
 145
 146 (defmethod read-binary ((type symbol) stream &rest key-args)
 147   (apply #'read-binary (find-binary-type type) stream key-args))
 148
 149 (defgeneric write-binary (type stream object &key &allow-other-keys)
 150   (:documentation "Write an OBJECT of TYPE to STREAM."))
 151
 152 (defmethod write-binary ((type symbol) stream object &rest key-args)
 153   (apply #'write-binary (find-binary-type type) stream object key-args))
 154
 155 (defclass binary-type ()
 156   ((name
 157     :initarg name
 158     :initform '#:anonymous-binary-type
 159     :reader binary-type-name)
 160    (sizeof
 161     :initarg sizeof
 162     :reader sizeof))
 163   (:documentation "BINARY-TYPE is the base class for binary types meta-classes."))
 164
 165 (defmethod print-object ((object binary-type) stream)
 166   (print-unreadable-object (object stream :type 'binary-type)
 167     (format stream "~A" (binary-type-name object))))
 168
 169 ;;; ----------------------------------------------------------------
 170 ;;;                      Integer Type (Abstract)
 171 ;;; ----------------------------------------------------------------
 172
 173 (defclass binary-integer (binary-type)
 174   ((endian :type endianess
 175            :reader binary-integer-endian
 176            :initarg endian
 177            :initform nil)))
 178
 179 (defmethod print-object ((type binary-integer) stream)
 180   (if (not *print-readably*)
 181       (print-unreadable-object (type stream :type t)
 182         (format stream "~D-BIT~@[ ~A~] INTEGER TYPE: ~A"
 183                 (* 8 (slot-value type 'sizeof))
 184                 (slot-value type 'endian)
 185                 (binary-type-name type)))
 186     (call-next-method type stream)))
 187
 188 ;;; WRITE-BINARY is identical for SIGNED and UNSIGNED, but READ-BINARY
 189 ;;; is not.
 190
 191 (defmethod write-binary ((type binary-integer) stream object &key &allow-other-keys)
 192   (check-type object integer)
 193   (if (= 1 (sizeof type))
 194       (progn (funcall *binary-write-byte* object stream) 1)
 195     (ecase (or (binary-integer-endian type)
 196                *endian*)
 197       ((:big-endian big-endian)
 198        (do ((i (* 8 (1- (sizeof type))) (- i 8)))
 199            ((minusp i) (sizeof type))
 200          (funcall *binary-write-byte* (ldb (byte 8 i) object) stream)))
 201       ((:little-endian little-endian)
 202        (dotimes (i (sizeof type))
 203          (funcall *binary-write-byte* (ldb (byte 8 (* 8 i)) object) stream))
 204        (sizeof type)))))
 205
 206 ;;; ----------------------------------------------------------------
 207 ;;;                      Unsigned Integer Types
 208 ;;; ----------------------------------------------------------------
 209
 210 (defclass binary-unsigned (binary-integer) ())
 211
 212 (defmacro define-unsigned (name size &optional endian)
 213   (check-type size (integer 1 *))
 214   (check-type endian endianess)
 215   `(progn
 216      (deftype ,name () '(unsigned-byte ,(* 8 size)))
 217      (setf (find-binary-type ',name)
 218        (make-instance 'binary-unsigned
 219          'name ',name
 220          'sizeof ,size
 221          'endian ,endian))
 222      ',name))
 223
 224 (define-unsigned u8 1)
 225 (define-unsigned u16 2)
 226 (define-unsigned u32 4)
 227
 228 (defmethod read-binary ((type binary-unsigned) stream &key &allow-other-keys)
 229   (if (= 1 (sizeof type))
 230       (values (funcall *binary-read-byte* stream)
 231               1)
 232     (let ((unsigned-value 0))
 233       (ecase (or (binary-integer-endian type)
 234                  *endian*)
 235         ((:big-endian big-endian)
 236          (dotimes (i (sizeof type))
 237            (setf unsigned-value (+ (* unsigned-value #x100)
 238                                    (funcall *binary-read-byte* stream)
 239                                    ))))
 240         ((:little-endian little-endian)
 241          (dotimes (i (sizeof type))
 242            (setf unsigned-value (+ unsigned-value
 243                                    (ash (funcall *binary-read-byte* stream)
 244                                         (* 8 i)))))))
 245       (values unsigned-value
 246               (sizeof type)))))
 247
 248 ;;; ----------------------------------------------------------------
 249 ;;;              Twos Complement Signed Integer Types
 250 ;;; ----------------------------------------------------------------
 251
 252 (defclass binary-signed (binary-integer) ())
 253
 254 (defmacro define-signed (name size &optional (endian nil))
 255   (check-type size (integer 1 *))
 256   (check-type endian endianess)
 257   `(progn
 258      (deftype ,name () '(signed-byte ,(* 8 size)))
 259      (setf (find-binary-type ',name)
 260        (make-instance 'binary-signed
 261          'name ',name
 262          'sizeof ,size
 263          'endian ,endian))
 264      ',name))
 265
 266 (define-signed s8 1)
 267 (define-signed s16 2)
 268 (define-signed s32 4)
 269
 270 (defmethod read-binary ((type binary-signed) stream &key &allow-other-keys)
 271   (let ((unsigned-value 0))
 272     (if (= 1 (sizeof type))
 273         (setf unsigned-value (funcall *binary-read-byte* stream))
 274       (ecase (or (binary-integer-endian type)
 275                  *endian*)
 276         ((:big-endian big-endian)
 277          (dotimes (i (sizeof type))
 278            (setf unsigned-value (+ (* unsigned-value #x100)
 279                                    (funcall *binary-read-byte* stream)
 280                                    ))))
 281         ((:little-endian little-endian)
 282          (dotimes (i (sizeof type))
 283            (setf unsigned-value (+ unsigned-value
 284                                    (ash (funcall *binary-read-byte* stream)
 285                                         (* 8 i))))))))
 286     (values (if (>= unsigned-value (ash 1 (1- (* 8 (sizeof type)))))
 287                 (- unsigned-value (ash 1 (* 8 (sizeof type))))
 288               unsigned-value)
 289             (sizeof type))))
 290
 291 ;;; ----------------------------------------------------------------
 292 ;;;                       Character Types
 293 ;;; ----------------------------------------------------------------
 294
 295 ;;; There are probably lots of things one _could_ do with character
 296 ;;; sets etc..
 297
 298 (defclass binary-char8 (binary-type) ())
 299
 300 (setf (find-binary-type 'char8)
 301   (make-instance 'binary-char8
 302     'name 'char8
 303     'sizeof 1))
 304
 305 (deftype char8 () 'character)
 306
 307 (defmethod read-binary ((type binary-char8) stream &key &allow-other-keys)
 308   (values (code-char (read-binary 'u8 stream))
 309           1))
 310
 311 (defmethod write-binary ((type binary-char8) stream object &key &allow-other-keys)
 312   (write-binary 'u8 stream (char-code object)))
 313
 314 ;;; ----------------------------------------------------------------
 315 ;;;     Padding Type (Implicitly defined and named by integers)
 316 ;;; ----------------------------------------------------------------
 317
 318 ;;; The padding type of size 3 octets is named by the integer 3, and
 319 ;;; so on.
 320
 321 (defmethod sizeof ((type integer)) type)
 322
 323 (defmethod read-binary ((type integer) stream &key &allow-other-keys)
 324   (dotimes (i type)
 325     (read-binary 'u8 stream))
 326   (values nil type))
 327
 328 (defvar *padding-byte* #x00
 329   "The value written to padding octets.")
 330
 331 (defmethod write-binary ((type integer) stream object &key &allow-other-keys)
 332   (declare (ignore object))
 333   (check-type *padding-byte* (unsigned-byte 8))
 334   (dotimes (i type)
 335     (write-binary 'u8 stream *padding-byte*))
 336   type)
 337
 338 ;;; ----------------------------------------------------------------
 339 ;;;                   String library functions
 340 ;;; ----------------------------------------------------------------
 341
 342 (defun read-binary-string (stream &key size terminators)
 343   "Read a string from STREAM, terminated by any member of the list TERMINATORS.
 344 If SIZE is provided and non-nil, exactly SIZE octets are read, but the returned
 345 string is still terminated by TERMINATORS. The string and the number of octets
 346 read are returned."
 347   (check-type size (or null (integer 0 *)))
 348   (check-type terminators list)
 349   (assert (or size terminators) (size terminators)
 350     "Can't read a binary-string without a size limitation nor terminating bytes.")
 351   (let (bytes-read)
 352     (values (with-output-to-string (string)
 353               (loop with string-terminated = nil
 354                   for count upfrom 0
 355                   until (if size (= count size) string-terminated)
 356                   do (let ((byte (funcall *binary-read-byte* stream)))
 357                        (cond
 358                         ((member byte terminators :test #'=)
 359                          (setf string-terminated t))
 360                         ((not string-terminated)
 361                          (write-char (code-char byte) string))))
 362                   finally (setf bytes-read count)))
 363             bytes-read)))
 364
 365 ;;; ----------------------------------------------------------------
 366 ;;;                  String Types
 367 ;;; ----------------------------------------------------------------
 368
 369 (defclass binary-string (binary-type)
 370   ((terminators
 371     :initarg terminators
 372     :reader binary-string-terminators)))
 373
 374 (defmacro define-binary-string (type-name size &key terminators)
 375   (check-type size (integer 1 *))
 376   `(progn
 377      (deftype ,type-name () 'string)
 378      (setf (find-binary-type ',type-name)
 379        (make-instance 'binary-string
 380          'name ',type-name
 381          'sizeof ,size
 382          'terminators ,terminators))
 383      ',type-name))
 384
 385 (defmacro define-null-terminated-string (type-name size)
 386   `(define-binary-string ,type-name ,size :terminators '(0)))
 387
 388 (defmacro define-fixed-size-nt-string (type-name size)
 389   ;; compatibility..
 390   `(define-null-terminated-string ,type-name ,size))
 391
 392 (defmethod read-binary ((type binary-string) stream &key &allow-other-keys)
 393   (read-binary-string stream
 394                       :size (sizeof type)
 395                       :terminators (binary-string-terminators type)))
 396
 397 (defmethod write-binary ((type binary-string) stream obj  &key &allow-other-keys)
 398   (check-type obj string)
 399   (dotimes (i (sizeof type))
 400     (if (< i (length obj))
 401         (funcall *binary-write-byte* (char-code (aref obj i)) stream)
 402       (funcall *binary-write-byte*
 403                ;; use the first member of TERMINATORS as writing terminator.
 404                (or (first (binary-string-terminators type)) 0)
 405                stream)))
 406   (sizeof type))
 407
 408 ;;; ----------------------------------------------------------------
 409 ;;;                    Record Types ("structs")
 410 ;;; ----------------------------------------------------------------
 411
 412 ;;;(defstruct compound-slot
 413 ;;;  name
 414 ;;;  type
 415 ;;;  on-write)
 416
 417 ;;;(defun make-record-slot (&key name type map-write)
 418 ;;;  (list name type map-write map-read))
 419 ;;;
 420 ;;;(defun record-slot-name (s) (first s))
 421 ;;;(defun record-slot-type (s) (second s))
 422 ;;;(defun record-slot-on-write (s) (third s))
 423
 424 (eval-when (:load-toplevel :compile-toplevel)
 425   (defstruct record-slot
 426     name
 427     type
 428     map-write
 429     map-read
 430     map-read-delayed
 431     hidden-read-slot
 432     tags))                              ; for map-read-delayed, the binary value is stored here.
 433
 434 (defmethod make-load-form ((object record-slot) &optional environment)
 435   (declare (ignore environment))
 436   (with-slots (name type map-write map-read map-read-delayed hidden-read-slot)
 437       object
 438     `(make-record-slot :name ',name
 439                        :type ',type
 440                        :map-write ,map-write
 441                        :map-read ,map-read
 442                        :map-read-delayed ,map-read-delayed
 443                        :hidden-read-slot ',hidden-read-slot)))
 444
 445 (defclass binary-record (binary-type)
 446   ((slots
 447     :initarg slots
 448     :accessor binary-record-slots)
 449    (offset
 450     :initarg offset
 451     :reader binary-record-slot-offset)))
 452
 453 (defclass binary-class (binary-record)
 454   ;; a DEFCLASS class with binary properties
 455   ((instance-class
 456     :type standard-class
 457     :initarg instance-class)))
 458
 459 (defmethod binary-record-make-instance ((type binary-class))
 460   (make-instance (slot-value type 'instance-class)))
 461
 462 (defclass binary-struct (binary-record)
 463   ;; A DEFSTRUCT type with binary properties
 464   ((constructor :initarg constructor)))
 465
 466 (defmethod binary-record-make-instance ((type binary-struct))
 467   (funcall (slot-value type 'constructor)))
 468
 469 (defun slot-offset (type slot-name)
 470   "Return the offset (in number of octets) of SLOT-NAME in TYPE."
 471   (unless (typep type 'binary-record)
 472     (setf type (find-binary-type type)))
 473   (check-type type binary-record)
 474   (unless (find-if #'(lambda (slot)
 475                        (eq slot-name (record-slot-name slot)))
 476                    (binary-record-slots type))
 477     (error "Slot ~S doesn't exist in type ~S."
 478            slot-name type))
 479   (+ (binary-record-slot-offset type)
 480      (loop for slot in (binary-record-slots type)
 481          until (eq slot-name (record-slot-name slot))
 482          summing (sizeof (record-slot-type slot)))))
 483
 484 (defun binary-slot-tags (type slot-name)
 485   (when (symbolp type)
 486     (setf type (find-binary-type type)))
 487   (let ((slot (find slot-name (binary-record-slots type) :key #'record-slot-name)))
 488     (assert slot (slot-name)
 489       "No slot named ~S in binary-type ~S." slot-name type)
 490     (record-slot-tags slot)))
 491
 492 (defun binary-record-slot-names (type &key (padding-slots-p nil)
 493                                            (match-tags nil))
 494   "Returns a list of the slot-names of TYPE, in sequence."
 495   (when (symbolp type)
 496     (setf type (find-binary-type type)))
 497   (when (and match-tags (atom match-tags))
 498     (setf match-tags (list match-tags)))
 499   (let ((slot-names (if padding-slots-p
 500                         (mapcar #'record-slot-name (binary-record-slots type))
 501                       (mapcan #'(lambda (slot)
 502                                   (if (integerp (record-slot-type slot))
 503                                       nil
 504                                     (list (record-slot-name slot))))
 505                               (binary-record-slots type)))))
 506     (if (null match-tags)
 507         slot-names
 508       (loop for slot-name in slot-names
 509           when (intersection (binary-slot-tags type slot-name)
 510                              match-tags)
 511           collect slot-name))))
 512
 513 (defun binary-slot-type (type slot-name)
 514   (when (symbolp type)
 515     (setf type (find-binary-type type)))
 516   (let ((slot (find slot-name (binary-record-slots type) :key #'record-slot-name)))
 517     (assert slot (slot-name)
 518       "No slot named ~S in binary-type ~S." slot-name type)
 519     (record-slot-type slot)))
 520
 521 (defun quoted-name-p (form)
 522   (and (listp form)
 523        (= 2 (length form))
 524        (eq 'cl:quote (first form))
 525        (symbolp (second form))
 526        (second form)))
 527
 528 (defun parse-bt-spec (expr)
 529   "Takes a binary-type specifier (a symbol, integer, or define-xx form),
 530   and returns three values: the binary-type's name, the equivalent lisp type,
 531   and any nested declaration that must be expanded separately."
 532   (cond
 533    ((eq :label expr) (values 0 nil))    ; a label
 534    ((symbolp expr) (values expr expr))  ; a name
 535    ((integerp expr) (values expr nil))  ; a padding type
 536    ((quoted-name-p expr)
 537     (values (second expr) (second expr))) ; a quoted name
 538    ((and (listp expr)                   ; a nested declaration
 539          (symbolp (first expr))
 540          (eq (find-package 'binary-types)
 541              (symbol-package (first expr))))
 542     (values (second expr) (second expr) expr))
 543    (t (error "Unknown nested binary-type specifier: ~S" expr))))
 544
 545 (defmacro define-binary-class (type-name supers slots &rest class-options)
 546   (let (embedded-declarations)
 547     (flet ((parse-slot-specifier (slot-specifier)
 548              "For a class slot-specifier, return the slot-specifier to forward
 549  (sans binary-type options), the binary-type of the slot (or nil),
 550  and the slot's name, and map-write, map-read and map-read-delayed
 551  functions if present."
 552              (when (symbolp slot-specifier)
 553                (setf slot-specifier (list slot-specifier)))
 554              (loop for slot-options on (rest slot-specifier) by #'cddr
 555                  as slot-option = (first slot-options)
 556                  as slot-option-arg = (second slot-options)
 557                  with bintype = nil
 558                  and typetype = nil
 559                  and map-write = nil
 560                  and map-read = nil
 561                  and map-read-delayed = nil
 562                  and tags = nil
 563                  unless
 564                    (case slot-option
 565                      (:binary-tag
 566                       (prog1 t
 567                         (setf tags (if (atom slot-option-arg)
 568                                        (list slot-option-arg)
 569                                      slot-option-arg))))
 570                      ((:bt-on-write :map-binary-write)
 571                       (prog1 t
 572                         (setf map-write slot-option-arg)))
 573                      (:map-binary-read
 574                       (prog1 t
 575                         (setf map-read slot-option-arg)))
 576                      (:map-binary-read-delayed
 577                       (prog1 t
 578                         (setf map-read-delayed slot-option-arg)))
 579                      ((:bt :btt :binary-type :binary-lisp-type)
 580                       (prog1 t
 581                         (multiple-value-bind (bt tt nested-form)
 582                             (parse-bt-spec slot-option-arg)
 583                           (setf bintype bt)
 584                           (when nested-form
 585                             (push nested-form embedded-declarations))
 586                           (when (and (symbolp tt)
 587                                      (member slot-option '(:btt :binary-lisp-type)))
 588                             (setf typetype tt))))))
 589                  nconc (list slot-option
 590                              slot-option-arg) into options
 591                  finally (return (values (list* (first slot-specifier)
 592                                                 (if typetype
 593                                                     (list* :type typetype options)
 594                                                   options))
 595                                          bintype
 596                                          (first slot-specifier)
 597                                          map-write
 598                                          map-read
 599                                          map-read-delayed
 600                                          tags)))))
 601       (multiple-value-bind (binslot-forms binslot-types hidden-slots)
 602           (loop for slot-specifier in slots with binslot-forms and binslot-types and hidden-slots
 603               do (multiple-value-bind (options bintype slot-name map-write map-read map-read-delayed tags)
 604                      (parse-slot-specifier slot-specifier)
 605                    (declare (ignore options))
 606                    (when bintype
 607                      (let ((hidden-read-slot-name (when map-read-delayed
 608                                                     (make-symbol (format nil "hidden-slot-~A"
 609                                                                          slot-name)))))
 610                        (push `(make-record-slot
 611                                :name ',slot-name
 612                                :type ',bintype
 613                                :map-write ,map-write
 614                                :map-read ,map-read
 615                                :map-read-delayed ,map-read-delayed
 616                                :hidden-read-slot ',hidden-read-slot-name
 617                                :tags ',tags)
 618                              binslot-forms)
 619                        (when (and hidden-read-slot-name
 620                                   (not *ignore-hidden-slots-for-pcl*))
 621                          (push (list hidden-read-slot-name slot-name map-read-delayed bintype)
 622                                hidden-slots))
 623                        (push bintype binslot-types))))
 624               finally (return (values (reverse binslot-forms)
 625                                       (reverse binslot-types)
 626                                       (reverse hidden-slots))))
 627         (let* ((forward-class-options (loop for co in class-options
 628                                           unless (member (car co)
 629                                                          '(:slot-align :class-slot-offset))
 630                                           collect co))
 631                (class-slot-offset (or (second (assoc :class-slot-offset class-options)) 0))
 632                (slot-align-slot (second (assoc :slot-align class-options)))
 633                (slot-align-offset (third (assoc :slot-align class-options))))
 634           `(progn
 635              ,@embedded-declarations
 636              (defclass ,type-name ,supers
 637                ,(append (mapcar #'parse-slot-specifier slots)
 638                         (mapcar #'first hidden-slots))
 639                ,@forward-class-options)
 640              (let ((record-size (loop for s in ',binslot-types summing (sizeof s))))
 641                (setf (find-binary-type ',type-name)
 642                  (make-instance 'binary-class
 643                    'name ',type-name
 644                    'sizeof record-size
 645                    'slots (list ,@binslot-forms)
 646                    'offset ,class-slot-offset
 647                    'instance-class (find-class ',type-name)))
 648                ,@(when slot-align-slot
 649                    `((setf (slot-value (find-binary-type ',type-name) 'offset)
 650                        (- ,slot-align-offset
 651                           (slot-offset ',type-name ',slot-align-slot)))))
 652                ,@(loop for bs in hidden-slots
 653                      collect `(defmethod slot-unbound (class (instance ,type-name)
 654                                                        (slot-name (eql ',(second bs))))
 655                                 (if (not (slot-boundp instance ',(first bs)))
 656                                     (call-next-method class instance slot-name)
 657                                   (setf (slot-value instance slot-name)
 658                                     (funcall ,(third bs)
 659                                              (slot-value instance ',(first bs))
 660                                              ',(fourth bs))))))
 661                ',type-name)))))))
 662
 663
 664 (defmacro define-binary-struct (name-and-options dummy-options &rest doc-slot-descriptions)
 665   (declare (ignore dummy-options))      ; clisp seems to require this..
 666   (let (embedded-declarations)
 667     (flet ((parse-slot-description (slot-description)
 668              (cond
 669               ((symbolp slot-description)
 670                (values slot-description nil slot-description))
 671               ((>= 2 (list-length slot-description))
 672                (values slot-description nil (first slot-description)))
 673               (t (loop for descr on (cddr slot-description) by #'cddr
 674                      with bintype = nil
 675                      and typetype = nil
 676                      if (member (first descr)
 677                                 '(:bt :btt :binary-type :binary-lisp-type))
 678                      do (multiple-value-bind (bt lisp-type nested-form)
 679                             (parse-bt-spec (second descr))
 680                           (declare (ignore lisp-type))
 681                           (setf bintype bt)
 682                           (when nested-form
 683                             (push nested-form embedded-declarations))
 684                           (when (and (symbolp bt)
 685                                      (member (first descr)
 686                                              '(:btt :binary-lisp-type)))
 687                             (setf typetype bintype)))
 688                      else nconc
 689                           (list (first descr) (second descr)) into descriptions
 690                      finally
 691                        (return (values (list* (first slot-description)
 692                                               (second slot-description)
 693                                               (if typetype
 694                                                   (list* :type typetype descriptions)
 695                                                 descriptions))
 696                                        bintype
 697                                        (first slot-description))))))))
 698       (multiple-value-bind (doc slot-descriptions)
 699           (if (stringp (first doc-slot-descriptions))
 700               (values (list (first doc-slot-descriptions))
 701                       (rest doc-slot-descriptions))
 702             (values nil doc-slot-descriptions))
 703         (let* ((type-name (if (consp name-and-options)
 704                               (first name-and-options)
 705                             name-and-options))
 706                (binslots (mapcan (lambda (slot-description)
 707                                    (multiple-value-bind (options bintype slot-name)
 708                                        (parse-slot-description slot-description)
 709                                      (declare (ignore options))
 710                                      (if bintype
 711                                          (list (make-record-slot :name slot-name
 712                                                                  :type bintype))
 713                                        nil)))
 714                                  slot-descriptions))
 715                (slot-types (mapcar #'record-slot-type binslots)))
 716           `(progn
 717              ,@embedded-declarations
 718              (defstruct ,name-and-options
 719                ,@doc
 720                ,@(mapcar #'parse-slot-description slot-descriptions))
 721              (setf (find-binary-type ',type-name)
 722                (make-instance 'binary-struct
 723                  'name ',type-name
 724                  'sizeof (loop for s in ',slot-types sum (sizeof s))
 725                  'slots ',binslots
 726                  'offset 0
 727                  'constructor (find-symbol (format nil "~A-~A" '#:make ',type-name))))
 728              ',type-name))))))
 729
 730 (defmethod read-binary-record (type-name stream &key start stop &allow-other-keys)
 731   (let ((type (find-binary-type type-name))
 732         (start-slot 0)
 733         (stop-slot nil))
 734     (check-type type binary-record)
 735     (when start
 736       (setf start-slot (position-if #'(lambda (sp)
 737                                         (eq start (record-slot-name sp)))
 738                                     (binary-record-slots type)))
 739       (unless start-slot
 740         (error "start-slot ~S not found in type ~A"
 741                start type)))
 742     (when stop
 743       (setf stop-slot (position-if #'(lambda (sp)
 744                                        (eq stop (record-slot-name sp)))
 745                                    (binary-record-slots type)))
 746       (unless stop-slot
 747         (error "stop-slot ~S not found in type ~A"
 748                stop  type)))
 749     (let ((total-read-bytes 0)
 750           (slot-list (subseq (binary-record-slots type) start-slot stop-slot))
 751           (object (binary-record-make-instance type)))
 752       (dolist (slot slot-list)
 753         (multiple-value-bind (read-slot-value read-slot-bytes)
 754             (read-binary (record-slot-type slot) stream)
 755           (cond
 756            ((record-slot-map-read-delayed slot)
 757             (setf (slot-value object (record-slot-hidden-read-slot slot))
 758               read-slot-value)
 759             (slot-makunbound object (record-slot-name slot)))
 760            ((record-slot-map-read slot)
 761             (setf (slot-value object (record-slot-name slot))
 762               (funcall (record-slot-map-read slot) read-slot-value)))
 763            (t (setf (slot-value object (record-slot-name slot)) read-slot-value)))
 764           (incf total-read-bytes read-slot-bytes)))
 765       (values object total-read-bytes))))
 766
 767 (defmethod read-binary ((type binary-record) stream &key start stop &allow-other-keys)
 768   (read-binary-record (binary-type-name type) stream :start start :stop stop))
 769
 770 (defmethod write-binary-record (object stream)
 771   (write-binary (find-binary-type (type-of object)) stream object))
 772
 773 (defun binary-slot-value (object slot-name)
 774   "Return the ``binary'' value of a slot, i.e the value mapped
 775 by any MAP-ON-WRITE slot mapper function."
 776   (let ((slot (find slot-name (binary-record-slots (find-binary-type (type-of object)))
 777                     :key #'record-slot-name)))
 778     (assert slot ()
 779       "Slot-name ~A not found in ~S of type ~S."
 780       slot-name object (find-binary-type (type-of object)))
 781 ;;;    (warn "slot: ~S value: ~S" slot (slot-value object slot-name))
 782     (cond
 783      ((integerp (record-slot-type slot)) nil) ; padding
 784      ((and (record-slot-map-read-delayed slot)
 785            (not (slot-boundp object slot-name))
 786            (slot-boundp object (record-slot-hidden-read-slot slot)))
 787       (slot-value object (record-slot-hidden-read-slot slot)))
 788      ((record-slot-map-write slot)
 789       (funcall (record-slot-map-write slot)
 790                (slot-value object slot-name)
 791                (record-slot-type slot)))
 792      (t (slot-value object slot-name)))))
 793
 794 (defmethod write-binary ((type binary-record) stream object
 795                          &key start stop &allow-other-keys)
 796   (let ((start-slot 0)
 797         (stop-slot nil))
 798     (when start
 799       (setf start-slot (position-if #'(lambda (sp)
 800                                         (eq start (record-slot-name sp)))
 801                                     (binary-record-slots type)))
 802       (unless start-slot
 803         (error "start-slot ~S not found in type ~A"
 804                start type)))
 805     (when stop
 806       (setf stop-slot (position-if #'(lambda (sp)
 807                                        (eq stop (record-slot-name sp)))
 808                                    (binary-record-slots type)))
 809       (unless stop-slot
 810         (error "stop-slot ~S not found in type ~A"
 811                stop type)))
 812     (let ((written-bytes 0)
 813           (slot-list (subseq (binary-record-slots type) start-slot stop-slot)))
 814       (dolist (slot slot-list)
 815         (let* ((slot-name (record-slot-name slot))
 816                (slot-type (record-slot-type slot))
 817                (value (cond
 818                        ((integerp slot-type) nil) ; padding
 819                        ((record-slot-map-write slot)
 820                         (funcall (record-slot-map-write slot)
 821                                  (slot-value object slot-name)
 822                                  slot-type))
 823                        (t (slot-value object slot-name)))))
 824           (incf written-bytes
 825                 (write-binary slot-type stream value))))
 826       written-bytes)))
 827
 828 (defun merge-binary-records (obj1 obj2)
 829   "Returns a record where every non-bound slot in obj1 is replaced
 830 with that slot's value from obj2."
 831   (let ((class (class-of obj1)))
 832     (unless (eq class (class-of obj2))
 833       (error "cannot merge incompatible records ~S and ~S" obj1 obj2))
 834     (let ((new-obj (make-instance class)))
 835       (dolist (slot (binary-record-slots (find-binary-type (type-of obj1))))
 836         (let ((slot-name (record-slot-name slot)))
 837           (cond
 838            ((slot-boundp obj1 slot-name)
 839             (setf (slot-value new-obj slot-name)
 840               (slot-value obj1 slot-name)))
 841            ((slot-boundp obj2 slot-name)
 842             (setf (slot-value new-obj slot-name)
 843               (slot-value obj2 slot-name))))))
 844       new-obj)))
 845
 846 (defun binary-record-alist (obj)
 847   "Returns an assoc-list representation of (the slots of) a binary
 848 record object."
 849   (mapcan #'(lambda (slot)
 850               (unless (integerp (record-slot-type slot))
 851                 (list (cons (record-slot-name slot)
 852                             (if (slot-boundp obj (record-slot-name slot))
 853                                 (slot-value obj (record-slot-name slot))
 854                               'unbound-slot)))))
 855           (binary-record-slots (find-binary-type (type-of obj)))))
 856
 857 ;;; ----------------------------------------------------------------
 858 ;;; Bitfield Types
 859 ;;; ----------------------------------------------------------------
 860
 861 (defclass bitfield (binary-type)
 862   ((storage-type
 863     :type t
 864     :accessor storage-type
 865     :initarg storage-type)
 866    (hash
 867     :type hash-table
 868     :initform (make-hash-table :test #'eq)
 869     :accessor bitfield-hash)))
 870
 871 (defstruct bitfield-entry
 872   value
 873   bytespec)
 874
 875 (defmacro define-bitfield (type-name (storage-type) spec)
 876   (let ((slot-list                      ; (slot-name value byte-size byte-pos)
 877          (mapcan #'(lambda (set)
 878                      (ecase (caar set)
 879                        (:bits
 880                         (mapcar #'(lambda (slot)
 881                                     (list (car slot)
 882                                           1
 883                                           1
 884                                           (cdr slot)))
 885                                 (make-pairs (cdr set))))
 886                        (:enum
 887                         (destructuring-bind (&key byte)
 888                             (rest (car set))
 889                           (mapcar #'(lambda (slot)
 890                                       (list (car slot)
 891                                             (cdr slot)
 892                                             (first byte)
 893                                             (second byte)))
 894                                   (make-pairs (cdr set)))))
 895                        (:numeric
 896                         (let ((s (car set)))
 897                           (list (list (second s)
 898                                       nil
 899                                       (third s)
 900                                       (fourth s)))))))
 901                  spec)))
 902     `(let ((type-obj (make-instance 'bitfield
 903                        'name ',type-name
 904                        'sizeof (sizeof ',storage-type)
 905                        'storage-type (find-binary-type ',storage-type))))
 906        (deftype ,type-name () '(or list symbol))
 907        (dolist (slot ',slot-list)
 908          (setf (gethash (first slot) (bitfield-hash type-obj))
 909            (make-bitfield-entry :value (second slot)
 910                                 :bytespec (if (and (third slot)
 911                                                    (fourth slot))
 912                                               (byte (third slot)
 913                                                     (fourth slot))
 914                                             nil))))
 915        (setf (find-binary-type ',type-name) type-obj)
 916        ',type-name)))
 917
 918 (defmacro define-enum (type-name (storage-name &optional byte-spec) &rest spec)
 919   "A simple wrapper around DEFINE-BITFIELD for simple enum types."
 920   `(define-bitfield ,type-name (,storage-name)
 921      (((:enum :byte ,byte-spec)
 922        ,@spec))))
 923
 924 (defun bitfield-compute-symbolic-value (type numeric-value)
 925   "Return the symbolic value of a numeric bitfield"
 926   (check-type numeric-value integer)
 927   (let (result)
 928     (maphash #'(lambda (slot-name entry)
 929                  (let ((e-value (bitfield-entry-value entry))
 930                        (e-bytespec (bitfield-entry-bytespec entry)))
 931                    (cond
 932                     ((and e-value e-bytespec)
 933                      (when (= e-value
 934                               (ldb e-bytespec numeric-value))
 935                        (push slot-name
 936                              result)))
 937                     (e-value
 938                      ;; no mask => this must be the sole entry present
 939                      (when (= numeric-value e-value)
 940                        (setf result slot-name)))
 941                     (e-bytespec
 942                      ;; no value => this is a numeric sub-field
 943                      (push (cons slot-name
 944                                  (ldb e-bytespec numeric-value))
 945                            result))
 946                     (t (error "bitfield-value type ~A has NIL value and bytespec" type)))))
 947              (bitfield-hash type))
 948 ;;;;; Consistency check by symmetry. Uncomment for debugging.
 949 ;;;    (unless (= numeric-value
 950 ;;;            (bitfield-compute-numeric-value type result))
 951 ;;;      (error "bitfield inconsitency with ~A: ~X => ~A => ~X."
 952 ;;;          (type-of type)
 953 ;;;          numeric-value
 954 ;;;          result
 955 ;;;          (bitfield-compute-numeric-value type result)))
 956     result))
 957
 958 (defun enum-value (type symbolic-value)
 959   "For an enum type (actually, for any bitfield-based type), ~
 960    look up the numeric value of a symbol."
 961   (unless (typep type 'bitfield)
 962     (setf type (find-binary-type type)))
 963   (bitfield-compute-numeric-value type symbolic-value))
 964
 965 (defun enum-symbolic-value (type binary-value)
 966   "The inverse of ENUM-VALUE."
 967   (unless (typep type 'bitfield)
 968     (setf type (find-binary-type type)))
 969   (bitfield-compute-symbolic-value type binary-value))
 970
 971 (defun bitfield-compute-numeric-value (type symbolic-value)
 972   "Returns the numeric representation of a bitfields symbolic value."
 973   (etypecase symbolic-value
 974     (list
 975      (let ((result 0))
 976        (dolist (slot symbolic-value)
 977          (etypecase slot
 978            (symbol                      ; enum sub-field
 979             (let ((entry (gethash slot (bitfield-hash type))))
 980               (assert entry (entry) "Unknown bitfield slot ~S of ~S."
 981                       slot (find-binary-type-name type))
 982               (setf (ldb (bitfield-entry-bytespec entry) result)
 983                 (bitfield-entry-value entry))))
 984            (cons                        ; numeric sub-field
 985             (let ((entry (gethash (car slot) (bitfield-hash type))))
 986               (assert entry (entry) "Unknown bitfield slot ~S of ~S."
 987                       (car slot) (find-binary-type-name type))
 988               (setf (ldb (bitfield-entry-bytespec entry) result)
 989                 (cdr slot))))))
 990        result))
 991     (symbol                             ; enum
 992      (let ((entry (gethash symbolic-value
 993                            (bitfield-hash type))))
 994        (assert entry (entry) "Unknown bitfield slot ~A:~S of ~S."
 995                (package-name (symbol-package symbolic-value))
 996                symbolic-value
 997                (find-binary-type-name type))
 998        (if (bitfield-entry-bytespec entry)
 999            (dpb (bitfield-entry-value entry)
1000                 (bitfield-entry-bytespec entry)
1001                 0)
1002          (bitfield-entry-value entry))))))
1003
1004 (defmethod read-binary ((type bitfield) stream &key &allow-other-keys)
1005   (multiple-value-bind (storage-obj num-octets-read)
1006       (read-binary (storage-type type) stream)
1007     (values (bitfield-compute-symbolic-value type storage-obj)
1008             num-octets-read)))
1009
1010 (defmethod write-binary ((type bitfield) stream symbolic-value &rest key-args)
1011   (apply #'write-binary
1012          (storage-type type)
1013          stream
1014          (bitfield-compute-numeric-value type symbolic-value)
1015          key-args))
1016
1017 ;;;; Macros:
1018
1019 (defmacro with-binary-file ((stream-var path &rest key-args) &body body)
1020   "This is a thin wrapper around WITH-OPEN-FILE, that tries to set the
1021 stream's element-type to that required by READ-BINARY and WRITE-BINARY.
1022 A run-time assertion on the stream's actual element type is performed,
1023 unless you disable this feature by setting the keyword option :check-stream
1024 to nil."
1025   (let ((check-stream (getf key-args :check-stream t))
1026         (fwd-key-args (copy-list key-args)))
1027     ;; This is manual parsing of keyword arguments. We force :element-type
1028     ;; to (unsigned-byte 8), and remove :check-stream from the arguments
1029     ;; passed on to WITH-OPEN-FILE.
1030     (remf fwd-key-args :check-stream)
1031     ;; #-(and allegro-version>= (version>= 6 0))
1032     (setf (getf fwd-key-args :element-type) ''(unsigned-byte 8))
1033     `(with-open-file (,stream-var ,path ,@fwd-key-args)
1034        ,@(when check-stream
1035            `((let ((stream-type (stream-element-type ,stream-var)))
1036                (assert (and (subtypep '(unsigned-byte 8) stream-type)
1037                             (subtypep stream-type '(unsigned-byte 8)))
1038                    ()
1039                  "Failed to open ~S in 8-bit binary mode, stream element-type was ~S"
1040                  ,path stream-type))))
1041        ,@body)))
1042
1043 (defmacro with-binary-output-to-list ((stream-var) &body body)
1044   "Inside BODY, calls to WRITE-BINARY with stream STREAM-VAR will
1045 collect the individual 8-bit bytes in a list (of integers).
1046 This list is returned by the form. (There is no way to get at
1047 the return-value of BODY.)
1048 This macro depends on the binding of *BINARY-WRITE-BYTE*, which should
1049 not be shadowed."
1050   (let ((save-bwt-var (make-symbol "save-bwt"))
1051         (closure-byte-var (make-symbol "closure-byte"))
1052         (closure-stream-var (make-symbol "closure-stream")))
1053     `(let* ((,save-bwt-var *binary-write-byte*)
1054             (,stream-var (cons nil nil)) ; (head . tail)
1055             (*binary-write-byte*
1056              #'(lambda (,closure-byte-var ,closure-stream-var)
1057                  (if (eq ,stream-var ,closure-stream-var)
1058                      (if (endp (cdr ,stream-var))
1059                          (setf (cdr ,stream-var)
1060                            (setf (car ,stream-var) (list ,closure-byte-var)))
1061                        (setf (cdr ,stream-var)
1062                          (setf (cddr ,stream-var) (list ,closure-byte-var))))
1063                    (funcall ,save-bwt-var ; it's not our stream, so pass it ...
1064                             ,closure-byte-var ; along to the next function.
1065                             ,closure-stream-var)))))
1066        ,@body
1067        (car ,stream-var))))
1068
1069 (defmacro with-binary-input-from-list ((stream-var list-form) &body body)
1070   "Bind STREAM-VAR to an object that, when passed to READ-BINARY, provides
1071 8-bit bytes from LIST-FORM, which must yield a list.
1072 Binds *BINARY-READ-BYTE* appropriately. This macro will break if this
1073 binding is shadowed."
1074   (let ((save-brb-var (make-symbol "save-brb")))
1075     `(let* ((,save-brb-var *binary-read-byte*)
1076             (,stream-var (cons ,list-form nil)) ; use cell as stream id.
1077             (*binary-read-byte* #'(lambda (s)
1078                                     (if (eq s ,stream-var)
1079                                         (if (null (car s))
1080                                             (error "WITH-BINARY-INPUT-FROM-LIST reached end of list.")
1081                                           (pop (car s)))
1082                                       (funcall ,save-brb-var s)))))
1083        ,@body)))
1084
1085 (defmacro with-binary-input-from-vector
1086     ((stream-var vector-form &key (start 0)) &body body)
1087   "Bind STREAM-VAR to an object that, when passed to READ-BINARY, provides
1088 8-bit bytes from VECTOR-FORM, which must yield a vector.
1089 Binds *BINARY-READ-BYTE* appropriately. This macro will break if this
1090 binding is shadowed."
1091   (let ((save-brb-var (make-symbol "save-brb")))
1092     `(let* ((,save-brb-var *binary-read-byte*)
1093             (,stream-var (cons (1- ,start) ,vector-form))
1094             (*binary-read-byte* #'(lambda (s)
1095                                     (if (eq s ,stream-var)
1096                                         (aref (cdr s) (incf (car s)))
1097                                       (funcall ,save-brb-var s)))))
1098        ,@body)))
1099
1100 (defmacro with-binary-output-to-vector
1101     ((stream-var &optional (vector-or-size-form 0)
1102       &key (adjustable (and (integerp vector-or-size-form)
1103                             (zerop vector-or-size-form)))
1104            (fill-pointer 0)
1105            (element-type ''(unsigned-byte 8))
1106            (on-full-array :error))
1107      &body body)
1108   "Arrange for STREAM-VAR to collect octets in a vector.
1109 VECTOR-OR-SIZE-FORM is either a form that evaluates to a vector, or an
1110 integer in which case a new vector of that size is created. The vector's
1111 fill-pointer is used as the write-index. If ADJUSTABLE nil (or not provided),
1112 an error will occur if the array is too small. Otherwise, the array will
1113 be adjusted in size, using VECTOR-PUSH-EXTEND. If ADJUSTABLE is an integer,
1114 that value will be passed as the EXTENSION argument to VECTOR-PUSH-EXTEND.
1115 If VECTOR-OR-SIZE-FORM is an integer, the created vector is returned,
1116 otherwise the value of BODY."
1117   (let ((vector-form
1118          (if (integerp vector-or-size-form)
1119              `(make-array ,vector-or-size-form
1120                           :element-type ,element-type
1121                           :adjustable ,(and adjustable t)
1122                           :fill-pointer ,fill-pointer)
1123            vector-or-size-form)))
1124     (let ((save-bwb-var (make-symbol "save-bwb")))
1125       `(let* ((,save-bwb-var *binary-write-byte*)
1126               (,stream-var ,vector-form)
1127               (*binary-write-byte*
1128                #'(lambda (byte stream)
1129                    (if (eq stream ,stream-var)
1130                        ,(cond
1131                          (adjustable
1132                           `(vector-push-extend byte stream
1133                                                ,@(when (integerp adjustable)
1134                                                    (list adjustable))))
1135                          ((eq on-full-array :error)
1136                           `(assert (vector-push byte stream) (stream)
1137                              "Binary output vector is full when writing byte value ~S: ~S"
1138                              byte stream))
1139                          ((eq on-full-array :ignore)
1140                           `(vector-push byte stream))
1141                          (t (error "Unknown ON-FULL-ARRAY argument ~S, must be one of :ERROR, :IGNORE."
1142                                    on-full-array)))
1143                      (funcall ,save-bwb-var byte stream)))))
1144          ,@body
1145          ,@(when (integerp vector-or-size-form)
1146              (list stream-var))))))
1147
1148
1149 ;;;
1150
1151 (defun split-bytes (bytes from-size to-size)
1152   "From a list of BYTES sized FROM-SIZE bits, split each byte into bytes of size TO-SIZE,
1153    according to *ENDIAN*. TO-SIZE must divide FROM-SIZE evenly. If this is not the case,
1154    you might want to apply MERGE-BYTES to the list of BYTES first."
1155   (assert (zerop (rem from-size to-size)) (from-size to-size)
1156     "TO-SIZE ~D doesn't evenly divide FROM-SIZE ~D." to-size from-size)
1157   (ecase *endian*
1158     (:little-endian
1159      (loop for byte in bytes
1160          append (loop for x from 0 below (truncate from-size to-size)
1161                     collect (ldb (byte to-size (* x to-size)) byte))))
1162     (:big-endian
1163      (loop for byte in bytes
1164          append (loop for x from (1- (truncate from-size to-size)) downto 0
1165                     collect (ldb (byte to-size (* x to-size)) byte))))))
1166 (defun merge-bytes (bytes from-size to-size)
1167   "Combine BYTES sized FROM-SIZE bits into new bytes sized TO-SIZE bits."
1168   (assert (zerop (rem to-size from-size)))
1169   (let ((factor (truncate to-size from-size)))
1170     (ecase *endian*
1171       (:little-endian
1172        (loop for bytes on bytes by #'(lambda (x) (nthcdr factor x))
1173            collect (loop for n from 0 below factor
1174                        as sub-byte = (or (nth n bytes) 0)
1175                        summing (ash sub-byte (* n from-size)))))
1176       (:big-endian
1177        (loop for bytes on bytes by #'(lambda (x) (nthcdr factor x))
1178            collect (loop for n from 0 below factor
1179                        as sub-byte = (or (nth (- factor 1 n) bytes) 0)
1180                        summing (ash sub-byte (* n from-size))))))))