binary-2.lisp

(in-package :lisp-binary)

(defun expand-defbinary-type-field (type-info)
  "Expands the :TYPE field of a DEFBINARY form. Returns three values:
     1. A :TYPE specifier that can be spliced into a slot definition in a DEFSTRUCT form.

     2. A READER-FORM that can be spliced into another function to read a datum of the specified
        type. The READER-FORM will assume that it will be spliced into a scope where there's
        a readable stream. The name of this stream must be stored in (SLOT-VALUE TYPE-INFO 'STREAM-SYMBOL).

     3. A WRITER-FORM to write such a datum. It can be spliced into a scope similar to that of the READER-FORM.

"
  (declare (type defbinary-type type-info)
	   (optimize (safety 3) (debug 3) (speed 0)))
  (loop for expander in *type-expanders*
     do (handler-bind ((no-destructuring-match
			 (lambda (exn)
			  (declare (ignore exn))
        #-allegro
			  (continue)
        #+allegro
        (invoke-restart 'continue-with-next-expander)
        )))
	  (restart-case
	      (return (multiple-value-bind (type reader writer)
			  (apply expander (cons type-info (let ((type (slot-value type-info 'type)))
							    (if (listp type)
								type
								(list type)))))
			(values `(:type ,type)
				(aif (slot-value type-info 'reader)
				     `(funcall ,it ,(slot-value type-info 'stream-symbol))
				     reader)
				(aif (slot-value type-info 'writer)
				     `(funcall ,it
					       ,(slot-value type-info 'name)
					       ,(slot-value type-info 'stream-symbol))
				     writer))))
      #-allegro
	    (continue () nil)
      #+allegro
      (continue-with-next-expander () nil)
      ))
       finally (error "Unknown LISP-BINARY type: ~s" (slot-value type-info 'type))))
	  
(defun defbinary-constructor-name (name defstruct-options)
  (let ((con (getf defstruct-options :constructor)))
    (or (if (consp con)
	    (car con)
	    con)
	(let ((*print-case* :upcase))
          (intern (format nil "MAKE-~a" name) (symbol-package name))))))

(defun expand-defbinary-field (name default-value &rest other-keys &key type (byte-order :little-endian)
							      byte-count-name
							      align element-align bit-stream-id
							      reader writer stream-symbol previous-defs-symbol
								     bind-index-to &allow-other-keys)
  "Expands the field into three values: A slot-descriptor suitable for CL:DEFSTRUCT, a form that reads this slot
from a stream, and a form that writes it to a stream. The reader and writer must be evaluated in a context where
the NAME is bound to the slot's value."
  (declare (optimize (safety 3) (debug 3) (speed 0)))
  (assert byte-count-name)
  (setf other-keys (remove-plist-keys other-keys :type :byte-order :encoding :terminator :reader :writer :stream-symbol :previous-defs-symbol
				      :byte-count-name :align :element-align :bind-index-to))
  (multiple-value-bind (real-type read-form write-form)
      (expand-defbinary-type-field
       (make-instance 'defbinary-type 
		      :name name 
		      :type type
		      :byte-order byte-order
		      :reader reader
		      :writer writer
		      :stream-symbol (or bit-stream-id stream-symbol)
		      :previous-defs-symbol previous-defs-symbol
		      :byte-count-name byte-count-name
		      :align align
		      :element-align element-align
		      :bind-index-to bind-index-to))
    (make-binary-field
     :type type
     :name name
     :defstruct-field `(,name ,default-value
			      ,@real-type ,@other-keys)
     :bit-stream-id bit-stream-id
     :read-form (if align 
		    `(progn
		       (incf ,byte-count-name (align-to-boundary ,byte-count-name
								 ,align #'read-bytes ,stream-symbol))
		       ,read-form)
		    read-form)
     :write-form (if align
		     `(progn
			(incf ,byte-count-name
			      (align-to-boundary ,byte-count-name
						 ,align (lambda (bytes stream)
							  (loop repeat bytes
							       do (write-byte 0 stream)))
						 ,stream-symbol))
			,write-form)
		     write-form))))

(defun bitfield-spec->defstruct-specs (name default-values options untyped-struct)
  (check-type name list)
  (let ((type (getf options :type)))
    (check-type type list)
    (unless (= (length name)
	       (length type))
      (error "In bitfield: Number of values ~a ~S doesn't match number of types ~a ~S"
	     (length name) name (length type) type))
    (loop for real-name in name
	 for default-value in default-values
       for real-type in type
       collect `(,real-name ,default-value
			    :type ,(if untyped-struct
				       t
				       real-type)
			    ,@(remove-plist-keys options :type)))))

(defun find-bit-field-groups (list &key (key #'identity))
  "Identifies those fields in the LIST of fields that must be
read/written either as a BIT-FIELD or through a BIT-STREAM wrapper.
A list of the original fields is returned, with those groups
that will be read/written in a non-byte-aligned mode grouped
in sublists.

See also: TYPE-SIZE"
  (named-let local-loop
      ((current-group nil)
       (result nil)
       (running-total 0)
       (list list))
    (let* ((field (car list))
	   (bits (and list
		      (funcall key field))))
      (cond ((null list)
	     (reverse
	      (if current-group
		  (cons (reverse current-group) result)
		  result)))
	    ((not (divisiblep (+ running-total bits) 8))
	     (local-loop (cons field current-group)
			 result
			 (+ running-total bits)
			 (cdr list)))
	    ((divisiblep (+ running-total bits) 8)
	     (local-loop nil
			 (cons (if current-group
				   (reverse (cons field current-group))
				   field)
			       result)
			 (+ running-total bits)
			 (cdr list)))
	    (t (error "Shouldn't ever be reached"))))))
	    

(defun field-description-plist (field-description)
  (cddr field-description))

(defun field-option (field-description option &optional default)
  (getf (field-description-plist field-description) option default))

(defun field-description-type (field-description)
  (getf (field-description-plist field-description)
	:type))

(defun combine-field-descriptions (field-descriptions)
  "Group the FIELD-DESCRIPTIONS according to how they should be grouped into bit-fields.

Returns two values:

  1. A list of fields very similar to the FIELD-DESCRIPTIONS, except that some elements of the
     list will be replaced by lists of fields that should be grouped together. Since a single
     field description is itself a list, use LIST-OF-FIELDS-P to tell the difference between
     one field and a list of fields.

  2. Either :BIT-STREAM-REQUIRED if the whole struct can only be read with a bit-stream,
     or no second value otherwise.
"

  (find-bit-field-groups field-descriptions
			 :key (lambda (field)
				(multiple-value-bind (bits can-use-bit-field contagious-bit-stream)
				    (type-size (field-description-type field))
				  (declare (ignore can-use-bit-field))
				  (cond
				    ((eq contagious-bit-stream :bit-stream-only)
				     (return-from combine-field-descriptions
				       (values field-descriptions :bit-stream-required)))
				    (t bits))))))

(defun bit-field-type-p (type)
  (destructuring-case type
    ((type-name size) :where (and (member type-name '(unsigned-byte signed-byte))
				  (integerp size))
     t)
    (otherwise nil)))

(defun list-of-fields-p (datum)
  (destructuring-case datum
    ((variables default-value &rest options &key type &allow-other-keys)
     :where (and (or (and (listp variables)
			  (listp type)
			  (eq (car type) 'bit-field))
		     (symbolp variables)))
     (declare (ignore options default-value))
     nil)
    (otherwise t)))
		 
(defun expand-byte-shorthand (n)
  (if (numberp n)
      (if (> n 0)
	  `(unsigned-byte ,n)
	  `(signed-byte ,(- n)))
      n))

(defun make-bit-field (source-fields)
  (let ((types (mapcar #'expand-byte-shorthand
		       (mapcar #'field-description-type source-fields)))
	(default-values (mapcar #'second source-fields)))
    (if (divisiblep (apply #'+ (mapcar 'type-size types)) 8)
	`(,(mapcar #'car source-fields)
	   ,default-values
	   :type (bit-field :member-types ,(loop for type in types
					      collect (if (bit-field-type-p type)
							  type
							  (invoke-restart 'cant-make-bit-field)))
			    :raw-type (unsigned-byte ,(loop for (nil bits) in types
							 sum bits))))
	(invoke-restart 'cant-make-bit-field))))

(defun add-bit-stream-id (field-descriptions)
  (loop for (name default-value . options) in field-descriptions
     with stream-id = (gensym "BITSTREAM-")
       collect (list* name default-value :bit-stream-id stream-id options)))

(defun externally-byte-aligned-p (field-descriptions)
  (divisiblep (apply #'+
		     (mapcar (lambda (f)
			       (type-size (field-description-type f)))
			     field-descriptions))
	      8))

(defun convert-to-bit-fields (field-descriptions)
  "Converts groups of non-byte-aligning field descriptions into bitfields where possible.
If they can't be read as bitfields, then a :BIT-STREAM-ID option is added to the field. "
  (cond ((externally-byte-aligned-p field-descriptions)
	 (multiple-value-bind (combined-field-descriptions message)
	     (combine-field-descriptions field-descriptions)
	   (cond ((eq message :bit-stream-required)
		  (values field-descriptions :bit-stream-required))
		 ;; I want to decide dynamically whether to COLLECT the
		 ;; result of MAKE-BIT-FIELD or APPEND the MAYBE-FIELD
		 ;; it tried to operate on, depending on whether a restart
		 ;; is invoked. LOOP doesn't allow this easily, so instead,
		 ;; I build a SCRIPT that consists of :APPEND and :COLLECT
		 ;; commands, and then interpret that script to get the
		 ;; final result.
		 (t (let ((script
			   (loop for maybe-field in combined-field-descriptions
			      append (if (list-of-fields-p maybe-field)
					 (restart-case
					     `(:collect ,(make-bit-field maybe-field))
					   (cant-make-bit-field ()
					     `(:append ,(add-bit-stream-id maybe-field))))
					 `(:collect ,maybe-field)))))
		      (loop for (command object) on script by #'cddr
			 if (eq command :collect)
			 collect object
			 else if (eq command :append)
			 append object
			 else do (error "Internal error: Unknown command ~S" command)))))))
	 (t (values field-descriptions :bit-stream-required))))


(defun recursive-field-list (current-list parents)
  "Build a list of fields; grandparents are included
  as their field lists are inclusive."
  (append (loop for p in (if (listp parents)
                             parents
                             (list parents))
                nconcing (get p :lisp-binary-fields))
          current-list))

(defparameter *last-f* nil)

(defun %make-reader-let-def (f form-value most-recent-byte-count previous-defs previous-defs-push previous-defs-symbol
			    byte-count-name byte-order)
  "Creates a single variable definition to go in the let-def form within READ-BINARY. F is a
BINARY-FIELD object that describes the field."
  (let* ((f-name (slot-value f 'name))
	  (f-form
	   (if (listp f-name)
	       (slot-value f 'read-form)
	       `(multiple-value-bind (,form-value ,most-recent-byte-count)
		    ,(slot-value f 'read-form)
		  (cond ((not (numberp ,most-recent-byte-count))
			 (restart-case
			     (error (format nil "Evaluation of ~a did not produce a byte count as its second value"
					    (with-output-to-string (out)
					      (print ',(slot-value f 'read-form) out))))
			   (use-value (val) :report "Enter an alternate value, dropping whatever was read."
					:interactive (lambda ()
						       (format t "Enter a new value for ~a: " ',f-name)
						       (list (eval (read))))
					(setf ,form-value val)
					(setf ,most-recent-byte-count 0))
								
			   (enter-size (size) :report "Enter a byte count manually"
				       :interactive (lambda ()
						      (format t "Enter the byte count: ")
						      (force-output)
						      (list (eval (read))))
				       (setf ,most-recent-byte-count size))))
			(t
			 (incf ,byte-count-name ,most-recent-byte-count)
			 ,form-value)))))
	  (x-form (subst* `((,previous-defs-symbol ,(reverse previous-defs)))
			  f-form)))
    (when (listp f-name)
      (setf f-name (ecase byte-order
		     (:little-endian (reverse f-name))
		     (:big-endian f-name)))
      (loop for real-name in f-name
	 do (funcall previous-defs-push (list real-name (list 'inject real-name))))
	 (funcall previous-defs-push (list f-name (list 'inject f-name))))
     (list f-name x-form)))

(defmacro make-reader-let-def (f)
  `(%make-reader-let-def ,f form-value most-recent-byte-count previous-defs (lambda (new-def)
									      (push new-def previous-defs))
			 previous-defs-symbol
			    byte-count-name byte-order))

(defun var-bit-stream (var bit-stream-groups)
  (maphash (lambda (stream vars)
	     (let ((field-object (find-if (lambda (field-object)
					    (eq var (slot-value field-object 'name)))
					  vars)))
	       (if field-object
		   (return-from var-bit-stream (values stream field-object)))))
	   bit-stream-groups))

(defun reverse-bit-stream-groups (bit-stream-hash real-stream-symbol let-defs)
  (loop for group in (group let-defs
			    :key (lambda (def)
				   (var-bit-stream (car def) bit-stream-hash)))
     append (if (eq (var-bit-stream (caar group) bit-stream-hash)
		    real-stream-symbol)
		group
		(reverse group))))

(defun add-stream-definitions (bit-stream-groups stream-symbol byte-order let-defs)
  "If the LET-DEFS contain fields that must be read from a bit-stream, this function
adds the necessary BIT-STREAM type variables to them. BIT-STREAM-GROUPS is a hash table
that maps each bit-stream variable name to the BINARY-FIELD objects of the variables that
must be read from that bit-stream. The STREAM-SYMBOL is the name of the default stream,
and BYTE-ORDER is the :BYTE-ORDER option passed to the DEFBINARY macro (only :BIG-ENDIAN
and :LITTLE-ENDIAN are supported. Handling for :DYNAMIC byte order must happen elsewhere)."
  (assert (member byte-order '(:big-endian :little-endian)))
  (loop for stream being the hash-keys in bit-stream-groups
     for var = (slot-value (car (last (gethash stream  bit-stream-groups)))
			   'name)
     do (setf let-defs
	      (insert-before var
			     `(,stream (wrap-in-bit-stream ,stream-symbol :byte-order ,byte-order))
			     let-defs
			     :key #'car)))
  let-defs)

(defun add-bit-stream-vars (bit-stream-groups stream-symbol byte-order make-let-def let-defs)
  (loop for (var def) in (add-stream-definitions bit-stream-groups stream-symbol byte-order let-defs)
     collect (multiple-value-bind (stream field-object)
		 (var-bit-stream var bit-stream-groups)
	       (if stream
		   (funcall make-let-def field-object stream)
		   `(,var ,def)))))


(defun group-write-forms (stream-names write-forms)
  "Groups a list of WRITE-FORMS according to which stream they write to. The
streams are identified by matching them to their names, which must be given in
STREAM-NAMES."
  (labels ((stream-used-here (form)
	     (recursive-find-if
	      (lambda (node)
		(member node stream-names))
	      form)))
  (loop for write-form-group in (group write-forms
				       :key #'stream-used-here)
     for stream-name = (stream-used-here write-form-group)
       collect (cons stream-name write-form-group))))


(defmacro defbinary (name (&rest defstruct-options
                           &key (byte-order :little-endian)
                             (preserve-*byte-order* t)
                             align
                             untyped-struct
                             include
                             documentation
                             export (byte-count-name (gensym "BYTE-COUNT-"))
                           &allow-other-keys)
                     &body direct-field-descriptions)
  "Defines a struct that represents binary data. Also generates two methods for this struct, named
READ-BINARY and WRITE-BINARY, which (de)serialize the struct to or from a stream. The serialization is
a direct binary representation of the fields of the struct. For instance, if there's a field with a :TYPE of
(UNSIGNED-BYTE 32), 4 bytes will be written in the specified :BYTE-ORDER. The fields are written (or read) in
the order in which they are specified in the body of the DEFBINARY form.

ARGUMENTS

  NAME - Used as the name in the generated DEFSTRUCT form.

  :BYTE-ORDER - The byte-order to use when reading or writing multi-byte
                data. Accepted values are :BIG-ENDIAN, :LITTLE-ENDIAN,
                and :DYNAMIC. If :DYNAMIC is specified, then the
                READ- and WRITE-BINARY methods will consult the special
                variable LISP-BINARY:*BYTE-ORDER* at runtime to decide
                which byte order to use. That variable is expected to
                be either :LITTLE-ENDIAN or :BIG-ENDIAN.
  
  :PRESERVE-*BYTE-ORDER* - Don't revert changes that get made to
                           LISP-BINARY:*BYTE-ORDER* during the call
                           to either READ- or WRITE-BINARY.

  :ALIGN - Align to the specified byte boundary before reading or writing
           the struct.
  
  :EXPORT - Export all symbols associated with the generated struct,
            including the name of the struct, the name of the constructor,
            and all the slot names.

  :BYTE-COUNT-NAME - In all value and type forms, bind to this name
                     the number of bytes in the struct written so far.

&ALLOW-OTHER-KEYS - All other keyword arguments will be passed through
                    to the generated CL:DEFSTRUCT form as part of the
                    NAME-AND-OPTIONS argument.

FIELD-DESCRIPTIONS - A list of slot specifications, having the following structure:

   (FIELD-NAME DEFAULT-VALUE &KEY TYPE BYTE-ORDER ALIGN ELEMENT-ALIGN
                                  READER WRITER BIND-INDEX-TO)

   The parameters have the following meanings:
   
   FIELD-NAME     - The name of the slot.
   
   DEFAULT-VALUE  - The default value.
   
   TYPE           - The type of the field. Some Common Lisp types such as
                    (UNSIGNED-BYTE 32) are supported. Any type defined
                    with DEFBINARY is also supported. For more info, see
                   'TYPES' below.
   
   BYTE-ORDER     - The byte order to use when reading or writing this
                    field. Defaults to the BYTE-ORDER given for the whole
                    struct.
   
   ALIGN          - If specified, reads and writes will be aligned on this
                    boundary. When reading, bytes will be thrown away until 
                    alignment is achieved. When writing, NUL bytes will be
                    written.

   UNTYPED-STRUCT - Don't declare the :TYPEs of the fields in the generated
                    DEFSTRUCT form.
   
   ELEMENT-ALIGN  - If the TYPE is an array, each element of the array will
                    be aligned to this boundary.
   
   READER         - If speficied, this function will be used to read the field.
                    It must accept one argument (a stream), and return two
                    values - The object read, and the the number of bytes read.
                    The number of bytes read is used for alignment purposes.
   
   WRITER         - If specified, this function will be used to write the field.
                    It must accept two arguments (the object to write, and the
                    stream), and return the number of bytes written, which is
                    used for alignment purposes.
   
   BIND-INDEX-TO  - If the EVAL type specifier is used as an array's element type
                    (see below), BIND-INDEX-TO will be bound to the current index
                    into the array, in case that matters for determining the type
                    of the next element.


Example:

   (defbinary simple-binary (:export t
                             :byte-order :little-endian)
       (magic 38284 :type (magic :actual-type (unsigned-byte 16)
                                 :value 38284))
       (size 0 :type (unsigned-byte 32))
       (oddball-value 0 :type (unsigned-byte 32)
                        :byte-order :big-endian)
       ((b g r) 0 :type (bit-field :raw-type (unsigned-byte 8)
                                   :member-types
                                        ((unsigned-byte 2)
                                         (unsigned-byte 3)
                                         (unsigned-byte 3))))
       (name \"\" :type (counted-string 1 :external-format :utf8))
       (alias #() :type (counted-buffer 4)
                  :byte-order :big-endian)
       (floating-point 0.0d0 :type double-float)
       (big-float 0 :type octuple-float)
       (odd-float 0 :type (double-float :byte-order :big-endian))
       (c-string \"\" :type (terminated-buffer 1 :terminator 0))
       (nothing nil :type null) ;; Reads and writes nothing.
       (other-struct nil :type other-binary 
                     :reader #'read-other-binary
                     :writer #'write-other-binary)
       (struct-array #() :type (counted-array 1 simple-binary))
       (blah-type 0 :type (unsigned-byte 32))
       (blah nil :type (eval (case oddball-value
                           ((1) '(unsigned-byte 32))
                           ((2) '(counted-string 2)))))
       (an-array #() :type (simple-array (unsigned-byte 32) ((length c-string))))
       (body #() :type (simple-array (unsigned-byte 8) (size))))

The above generates a DEFSTRUCT definition for SIMPLE-BINARY, along with
a definition for a READ-BINARY method and a WRITE-BINARY method.
`
The READ-BINARY method is EQL-specialized, and will construct the needed
object for you. It can be invoked like this:

    (read-binary 'simple-binary stream)

The WRITE-BINARY method is called like this:

    (write-binary object stream)

TYPES

    DEFBINARY supports two kinds of types: Ordinary Common Lisp types, and Virtual Types.

    The list of type names known to the library are listed below. Each one has its own
    docstring, which can be accessed in several ways:

    1. Emacs/SLIME's built-in docstring integraton: C-d d
    2. (CL:DOCUMENTATION symbol 'LISP-BINARY:LISP-BINARY-TYPE)
    3. (DESCRIBE symbol)

        UNSIGNED-BYTE
        SIGNED-BYTE
        SIMPLE-ARRAY
        COUNTED-ARRAY
        COUNTED-STRING
        COUNTED-BUFFER
        TERMINATED-STRING
        TERMINATED-BUFFER
        FIXED-LENGTH-STRING
        MAGIC
        BASE-POINTER
        FILE-POSITION
        (REGION-TAG &key base-pointer-name)
        (POINTER &key pointer-type data-type base-pointer-name region-tag)
        (BIT-FIELD &key raw-type member-types)
        (CUSTOM &key reader writer (lisp-type t))
        NULL
        EVAL - For runtime type selection

NON-BYTE-ALIGNED I/O: AN ALTERNATIVE TO BIT FIELDS

          DEFBINARY supports non-byte-aligned reads. For example, if you want to read a 4-bit
          unsigned integer and a 12-bit signed integer:

            (defbinary non-conforming (:byte-order :big-endian)
              (x 0 :type 4) 
              (y 0 :type 12)) ;; Total: 16 bits.

          The above will compile to a single 16-bit read, and the two values will be automatically
          extracted into their respective fields. The reverse operation is generated for writing.

          In fact, the above is converted into a BIT-FIELD declaration, so it is exactly equivalent
          to the following:

            (defbinary non-conforming-bit-field-version (:byte-order :big-endian)
              ((x y) 0 :type (bit-field :raw-type (unsigned-byte 16)
                                        :member-types ((unsigned-byte 4)
                                                       (unsigned-byte 12)))))

          The macro will group sets signed or unsigned bytes to achieve a read that consists of
          whole bytes. This grouping mechanism only works for SIGNED-BYTE and UNSIGNED-BYTE integers.

          For other types, DEFBINARY will generate a temporary BIT-STREAM for the non-byte-aligned parts:

             (defbinary non-byte-aligned-string (:byte-order :big-endian)
               (x 0 :type 4)
               (string \"\" :type (counted-string 1))
               (y 0 :type 4))
             ;; End of non-byte-aligned part
               (z \"\" :type (counted-string 1)))

          As long as the sum of the bits adds up to a whole number of bytes, no
          special handling is required on the part of the programmer. Internally,
          the above generates a temporary bit-stream and reads from it, and it discards
          the bit-stream before reading Z, because Z doesn't require non-byte-aligned I/O.
          This is slower than doing whole-byte reads.

          Finally, you can specify bytes that throw off the byte-alignment of the
          stream:

              (defbinary stays-non-byte-aligned ()
                 (x 0 :type 3))

          If the macro cannot group the fields in the struct into byte-aligned reads,
          then the struct can only be read from a BIT-STREAM and not a normal
          stream (see WRAP-IN-BIT-STREAM and WITH-WRAPPED-IN-BIT-STREAM). In this
          case, the macro will generate READ-BINARY and WRITE-BINARY methods that
          are specialized to a second argument of type BIT-STREAM.

          BIT-STREAMs can wrap any type of stream, including other BIT-STREAMs. This
          means that you can nest one struct that does BIT-STREAM I/O inside another:

             (defbinary stays-non-byte-aligned ()
                (x 0 :type 3)
                (y nil :type non-byte-aligned-string)) ;; See above


NON-BYTE-ALIGNED FIELDS and LITTLE ENDIANNESS

  Bit fields are inherently confusing when they are applied to little-endian data (unlike
  big-endian data, where they make perfect sense). This is because programmers who write
  specifications for little-endian formats sometimes still describe the bit fields by
  starting with the most significant bit.

  Also, code that handles bit fields from little endian data may also handle that data
  starting with the most significant bit (including some byte-order-independent code in
  this library).

  The BIT-FIELD type in DEFBINARY adds to this confusion, since the fields must always
  be given starting with the most significant bit, regardless of the format's byte order.

  However, when specifying non-byte-aligned fields without using BIT-FIELDs, they must be
  specified starting with the LEAST significant bit in a LITTLE-ENDIAN format, but they
  must be specified starting with the MOST significant bit in a BIG-ENDIAN format. For
  example, consider the following toy format:

     (defbinary toy-format (:byte-order :little-endian)
       (a 0 :type 4)
       (b 0 :type 16)
       (c 0 :type 4))

  Write it to disk with the following code:

     (with-open-binary-file (out #P\"/tmp/test-1.bin\" :direction :output
 					 :if-exists :supersede
					 :if-does-not-exist :create)
	       (write-binary (make-toy-format :a #x1 :b #x2345 :c #x6) out))

  The resulting file would produce the following confusing hex dump:

    51 34 62

  What is that 5 from the middle doing at the very beginning?!?! Since 0x5 is
  the second-least-significant nibble in the structure, it appears in the
  most significant nibble of the least significant byte. 

  Reading the above as a little-endian, 24-bit unsigned integer gives the
  integer #x623451, which is what you should have been expecting, since
  C is the most significant field, and its value is 6.

  You can also specify the above format using the BIT-FIELD type. But then you
  have to account for the fact that in a BIT-FIELD type description, you always
  describe the most significant bits first, no matter what. So the variables
  and their corresponding types have to be reversed:

     (defbinary toy-format/bit-field (:byte-order :little-endian)
       ((c b a) nil :type (bit-field :raw-type (unsigned-byte 24)
                                     :member-types ((unsigned-byte 4)
                                                    (unsigned-byte 16)
                                                    (unsigned-byte 4)))))


ALIGNMENT

  DEFBINARY can generate aligned structures. Alignment is calculated as an offset from the beginning of the structure
  being defined. If a SIMPLE-ARRAY is defined with :ALIGN-ELEMENT {boundary}, then each element will be aligned to that
  boundary. On writes, the alignment is achieved by writing NUL (0) bytes. On reads, the alignment is performed by
  reading bytes from the stream one at a time. Alignment is always performed before reading and writing, never after.

MANUAL ALIGNMENT

    If the &KEY argument :BYTE-COUNT-NAME is specified, then the name given will be bound as a variable whose value is the number of bytes read or
    written so far. This binding is visible in forms that are evaluated at runtime, such as array-length specifiers and EVAL type
    specifiers. 

FLOATING-POINT NUMBERS

   DEFBINARY can read IEEE floats ranging from half-precision up to octuple precision. Double-precision and below are
   represented in memory by hardware floats, while larger-precision floats are decoded into RATIONALs.

   Furthermore, single and double-precision floats are decoded from their byte representation by using CFFI, which
   lets the hardware do the work on those systems that have FPUs (such as x86/AMD machines).

   All other types of floating-point number are encoded and decoded using arithmetic.

"
  (setf defstruct-options
	(remove-plist-keys defstruct-options :export :byte-order :byte-count-name :align :untyped-struct :preserve-*byte-order* :documentation))
  (let-values* ((stream-symbol (gensym "STREAM-SYMBOL-"))
                (*ignore-on-write* nil)
                (bit-stream-groups (make-hash-table))
                (previous-defs-symbol (gensym "PREVIOUS-DEFS-SYMBOL-"))
                (most-recent-byte-count (gensym "MOST-RECENT-BYTE-COUNT-"))
                (form-value (gensym "FORM-VALUE-"))
                ((field-descriptions bit-stream-required) (convert-to-bit-fields (recursive-field-list direct-field-descriptions include)))
                ((direct-fields fields) (flet ((field-descriptions-fields (field-descriptions)
                                                 (loop for f in field-descriptions
                                                       collect (apply #'expand-defbinary-field
                                                                      (append f `(:stream-symbol ,stream-symbol :byte-count-name ,byte-count-name
                                                                                  :previous-defs-symbol ,previous-defs-symbol)
                                                                              (if (field-option f :byte-order)
                                                                                  nil
                                                                                  `(:byte-order ,(if (eq byte-order :dynamic)
                                                                                                     '*byte-order*
                                                                                                     byte-order))))))))
                                          (values
                                           (field-descriptions-fields direct-field-descriptions)
                                           (field-descriptions-fields field-descriptions))))
                (name-and-options (if defstruct-options
                                      (cons name
                                            (loop for (key value) on (remove-plist-keys defstruct-options :byte-order) by #'cddr
                                                  collect (list key value)))
                                      name))
                (documentation (if documentation
                                   (list documentation)
                                   nil))
                (previous-defs nil))    
    (declare (optimize (safety 3)))
    
    (pushover (cons name field-descriptions) *known-defbinary-types*
              :key #'car)
    (setf (get name :lisp-binary-fields)
          field-descriptions)
    (loop for f in fields do
      (awhen (slot-value f 'bit-stream-id)
        (push f (gethash it bit-stream-groups nil))))
    
    ((lambda (form)
       (if preserve-*byte-order*
           form
           (remove-binding '*byte-order* form)))
     `(progn
        (defstruct ,name-and-options ,@documentation
                   ,@(loop for (name default-value . options) in
                                                              (mapcar #'binary-field-defstruct-field direct-fields)
                           for type = (getf options :type)
                           if (listp name)
                             append (bitfield-spec->defstruct-specs
                                     name default-value options untyped-struct)
                           else collect (list* name default-value
                                               :type (if untyped-struct t
                                                         type)
                                               (remove-plist-keys options :type :bit-stream-id))))
        (defmethod read-binary ((type (eql ',name)) ,(if bit-stream-required
                                                         `(,stream-symbol bit-stream)
                                                         stream-symbol))
          ,@(if align
                `((let* ((current-pos (file-position ,stream-symbol))
                         (mod (mod current-pos ,align)))
                    (unless (= mod 0)
                      (file-position ,stream-symbol
                                     (+ current-pos (- ,align mod)))))))

          ,(flet ((make-reader-body (byte-order)
                    `(let-values* ,(list* `(,byte-count-name 0)
                                          '(*byte-order* *byte-order*)
                                          (add-stream-definitions bit-stream-groups
                                                                  stream-symbol
                                                                  byte-order
                                                                  (loop for f in fields
                                                                        if (eq (slot-value f 'type) 'null)
                                                                          collect
                                                                        `(,(slot-value f 'name) nil)
                                                                        else collect (make-reader-let-def f)
                                                                        finally (setf previous-defs nil))))
                       (values
                        (,(defbinary-constructor-name name defstruct-options)
                         ,@(loop for name in (mapcar #'binary-field-name fields)
                                 if (symbolp name)
                                   collect (intern (symbol-name name) :keyword)
                                   and collect name
                                 else append (loop for real-name in name
                                                   collect (intern (symbol-name real-name) :keyword)
                                                   collect real-name)))
                        ,byte-count-name))))
             (if (eq byte-order :dynamic)
                 `(ecase *byte-order*
                    (:big-endian ,(make-reader-body :big-endian))
                    (:little-endian ,(make-reader-body :little-endian)))
                 (make-reader-body byte-order))))
        
        (defmethod write-binary ((,name ,name) ,(if bit-stream-required
                                                    `(,stream-symbol bit-stream)
                                                    stream-symbol))
          ,@(if align
                `((let* ((current-pos (file-position ,stream-symbol))
                         (mod (mod current-pos ,align)))
                    (unless (= mod 0)
                      (loop repeat (- ,align mod) do (write-byte 0 ,stream-symbol))))))
          ,(let ((ignore-decls (append *ignore-on-write*
                                       (loop for field in fields
                                             when
                                             (destructuring-case (binary-field-type field)
                                               ((eval &rest args)
                                                :where (eq eval 'eval)
                                                (declare (ignore args))
                                                t)
                                               (otherwise nil))
                                             collect (binary-field-name field))))
                 (slots (loop for f in (mapcar #'binary-field-name
                                               fields)
                              if (listp f)
                                append f
                              else collect f)))
             `(let* ,(list `(,byte-count-name 0)
                           '(*byte-order* *byte-order*))
                (with-slots ,slots ,name
                  ,@(if ignore-decls
                        `((declare (ignorable ,@ignore-decls))))
                  ,@(loop for (stream-name . body)
                            in (group-write-forms (cons stream-symbol
                                                        (remove nil (mapcar #'binary-field-bit-stream-id fields)))
                                                  (loop for processed-write-form in
                                                                                 (loop for write-form in (mapcar #'binary-field-write-form fields)
                                                                                       when (recursive-find 'eval write-form)
                                                                                         collect (let ((fixed-let-defs (loop for var in slots collect
                                                                                                                                              (CONS VAR (CONS (list 'inject VAR) 'NIL)))))
                                                                                                   (subst* `((,previous-defs-symbol ,fixed-let-defs))
                                                                                                           write-form))
                                                                                       else collect write-form)
                                                        collect `(incf ,byte-count-name ,processed-write-form)))
                          collect `(,@(if (or (null stream-name)
                                              (eq stream-name stream-symbol))
                                          '(progn)
                                          `(with-wrapped-in-bit-stream (,stream-name ,stream-symbol
                                                                        :byte-order ,(if (eq byte-order :dynamic)
                                                                                         '*byte-order*
                                                                                         byte-order))))
                                    ,@body))
                  
                  ,byte-count-name))))
        ,@(when export
            `((export ',name)
              (export ',(defbinary-constructor-name name defstruct-options))
              ,@(loop for f in (mapcar #'binary-field-name fields)
                      if (listp f)
                        append (loop for real-name in f
                                     collect `(export ',real-name))
                      else collect `(export ',f))))
        ',name))))