Plaster

common-lisp
(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)))