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