Another N hours wasted... :|

(in-package #:k.binary.structures)

(defclass %slot ()
  ((accessor :initarg :accessor
             :reader %accessor-of
             :type symbol)
   (count :initarg :count
          :reader %count-of
          :type (integer 1))
   (name :initarg :name
         :reader %name-of
         :type symbol)
   (offset :initarg :offset
           :reader %offset-of
           :type (integer 0))
   (type :initarg :type
         :reader %type-of
         :type %type)))

(defclass %structure (%type)
  ((constructor :initarg :constructor
                :reader %constructor-of
                :type symbol)
   (offset :initarg :offset
           :reader %offset-of
           :type (integer 0))
   (slots :initarg :slots
          :reader %slots-of
          :type list)
   (superstructure :initarg :superstructure
                   :reader %superstructure-of
                   :type (or null %structure))))

(defstruct (binary-structure
            (:constructor %make-binary-structure))
  "The superstructure of all binary structures.")

(setf (%symbol-type 'binary-structure)
      (make-instance '%structure
                     :constructor '%make-binary-structure
                     :name 'binary-structure
                     :offset 0
                     :size 0
                     :slots nil
                     :superstructure nil))

(defmethod %read-from (offset (type %structure) vector)
  (let ((instance (funcall (%constructor-of type))))
    (%read-slots-from instance offset vector)
    instance))

(defgeneric %read-slots-from (instance offset vector)
  (:method-combination progn :most-specific-last))

(defmethod %size-of ((instance %slot))
  (* (%count-of instance)
     (%size-of (%type-of instance))))

(defun %structure-p (object)
  (typep object '%structure))

(defmethod %write-into (offset (type %structure) value vector)
  (%write-slots-into value offset vector))

(defgeneric %write-slots-into (instance offset vector)
  (:method-combination progn :most-specific-last))

(defun canonicalize-superstructure (superstructure-name)
  (let ((superstructure-name
         (or superstructure-name 'binary-structure)))
    (check-type superstructure-name symbol)
    (assert (subtypep superstructure-name 'binary-structure))
    (%symbol-type superstructure-name)))

(defun make-array-initform (count initform type)
  `(make-array ,count
               :element-type ',(%name-of type)
               ,@(if (%primitive-p type)
                     `(:initial-element ,initform)
                     `(:initial-contents
                       `#(,,@(loop for i below count
                                   collect initform))))))

(defun make-defstruct-form (structure)
  (let ((name (%name-of structure)))
    `(defstruct (,name
                 (:conc-name ,(symbolicate '% name '-))
                 (:constructor ,(%constructor-of structure))
                 (:include ,(%name-of (%superstructure-of structure))))
       ,@(mapcar #'make-defstruct-slot-description
                 (%slots-of structure)))))

(defun make-defstruct-slot-initform (count type)
  (let ((initform (%initform-for type)))
    (if (> count 1)
        (make-array-initform count initform type)
        initform)))

(defun make-defstruct-slot-description (slot)
  (let ((count (%count-of slot))
        (type (%type-of slot)))
    `(,(%name-of slot)
      ,(make-defstruct-slot-initform count type)
      :type
      ,(make-defstruct-slot-type count type))))

(defun make-defstruct-slot-type (count type)
  (let ((type-name (%name-of type)))
    (if (> count 1)
        `(array ,type-name (,count))
        type-name)))

(defun make-read-form (accessor count start type vector)
  (cond ((> count 1)
         (with-gensyms (index offset storage)
           `(loop with ,storage = ,accessor
                  for ,index from 0 below ,count
                  for ,offset from ,start by ,(%size-of type)
                  do ,(make-read-form `(aref ,storage ,index)
                                      1
                                      offset
                                      type
                                      vector))))
         ((%structure-p type)
          `(%read-slots-from ,accessor ,start ,vector))
         (t `(setf ,accessor
                   (read-from ',(%name-of type) ,vector ,start)))))

(defun make-slot-accessor-call (place structure slot)
  (let ((accessor-name
         (symbolicate '%
                      (%name-of structure)
                      '-
                      (%name-of slot))))
    `(,accessor-name ,place)))

(defun make-slot-reader-method (structure slot)
  (with-gensyms (index instance)
    (if (> (%count-of slot) 1)
        `(defmethod ,(%accessor-of slot)
             ((,instance ,(%name-of structure)) ,index)
           (check-type ,index array-index)
           (aref ,(make-slot-accessor-call instance structure slot)
                 ,index))
        `(defmethod ,(%accessor-of slot)
             ((,instance ,(%name-of structure)))
           ,(make-slot-accessor-call instance structure slot)))))

(defun make-structure-reader-method (structure)
  (with-gensyms (instance offset vector)
    `(defmethod %read-slots-from
         ((,instance ,(%name-of structure)) ,offset ,vector)
       ,@(loop for slot in (%slots-of structure)
               collect (make-read-form
                        (make-slot-accessor-call instance structure slot)
                        (%count-of slot)
                        `(+ ,offset ,(%offset-of slot))
                        (%type-of slot)
                        vector)))))

(defun make-slot-writer-method (structure slot)
  (with-gensyms (index instance value)
    (if (> (%count-of slot) 1)
        `(defmethod (setf ,(%accessor-of slot))
             (,value (,instance ,(%name-of structure)) ,index)
           (check-type ,value ,(%name-of (%type-of slot)))
           (check-type ,index array-index)
           (setf (aref ,(make-slot-accessor-call instance
                                                 structure
                                                 slot)
                       ,index)
                 ,value)
           ,value)
        `(defmethod (setf ,(%accessor-of slot))
             (,value (,instance ,(%name-of structure)))
           (check-type ,value ,(%name-of (%type-of slot)))
           (setf ,(make-slot-accessor-call instance structure slot)
                 ,value)
           ,value))))

(defun parse-slot-definition (offset slot-definition)
  (check-type slot-definition list)
  (destructuring-bind (name &key accessor (count 1) type)
      slot-definition
    (check-type name symbol)
    (check-type accessor symbol)
    (check-type count (integer 1))
    (check-type type symbol)
    (make-instance '%slot
                   :accessor accessor
                   :count count
                   :name name
                   :offset offset
                   :type (%symbol-type type))))

(defun parse-slot-definitions (offset slot-definitions)
  (mapcar #'(lambda (slot-definition)
              (let ((slot
                     (parse-slot-definition offset
                                            slot-definition)))
                (incf offset (%size-of slot))
                slot))
          slot-definitions))

(defun parse-structure-definition
    (name slot-definitions superstructure-name)
  (let* ((superstructure
          (canonicalize-superstructure superstructure-name))
         (offset (%size-of superstructure))
         (slots
          (parse-slot-definitions offset slot-definitions)))
    (make-instance '%structure
                   :constructor (symbolicate '%make- name)
                   :name name
                   :offset offset
                   :size (reduce #'+ slots :key #'%size-of)
                   :slots slots
                   :superstructure superstructure)))

(defmacro define-binary-structure
    (name (&optional superstructure-name) &body slot-definitions)
  (check-type name symbol)
  (check-type superstructure-name (or null symbol))
  (let ((structure
         (parse-structure-definition name
                                     slot-definitions
                                     superstructure-name)))
    `(progn
       ,(make-defstruct-form structure)

       ,@(loop for slot in (%slots-of structure)
               collect (make-slot-reader-method structure slot)
               collect (make-slot-writer-method structure slot))

       ,(make-structure-reader-method structure)
       ',name)))

(macroexpand
  `(define-binary-structure Sa ()
     (sa :accessor Sa-sa
         :type k.binary.integers:uint8)
     (sb :accessor Sa-sb
         :count 3
         :type k.binary.integers:uint8)
     (sc :accessor Sa-sc
         :type k.binary.integers:uint32)))