defbinstruct first try

gistfile1.lisp

(defun read-bytes (n &optional (in *standard-input*))
  (apply #'+ (loop for i from 0 to (1- n)
                   collect (ash (read-byte in) (* 8 (- n (1+ i)))))))

(defmacro remove-keywords (form)
  (cond ((null form) '())
        ((integerp form)
         `(read-bytes ,form stream))
        ((and (consp form) (keywordp (first form)))
         (case (first form)
           ((:list)
            `(loop for s from 0 to (1- ,(third form))
                   collect (remove-keywords ,(second form))))
           ((:vector)
            `(coerce (loop for s from 0 to (1- ,(third form))
                           collect (remove-keywords ,(second form)))
                     'vector))
           ((:struct)
            `(,(intern (concatenate 'string "READ-" (string (second form)))) stream))))
        (t form)))

(defmacro defbinstruct (name &body attributes)
  (labels ((make-reader-name (name-symbol)
             (intern (concatenate 'string "READ-" (string name-symbol)))))
    (if (and (keywordp (first attributes))
             (eql (first attributes) :custom))
        (let ((attributes (second attributes))
              (body (cddr attributes)))
          `(progn
             (defstruct ,name
               ,@attributes)

             (defun ,(make-reader-name name) (stream)
               ,@body)))
        (let ((attr-struct-names (remove-if-not #'identity
                                                (mapcar (lambda (attr)
                                                          (unless (keywordp (first attr))
                                                            (first attr)))
                                                        attributes))))
          `(progn
             (defstruct ,name
               ,@attr-struct-names)

             (defun ,(make-reader-name name) (stream)
               (let* (,@(mapcar (lambda (attr)
                                  (destructuring-bind (attr-name . bytes)
                                      (if (keywordp (first attr))
                                          (cons (caadr attr) (cadadr attr))
                                          (cons (first attr) (second attr)))
                                    `(,attr-name ,(if (integerp bytes)
                                                      `(read-bytes ,bytes stream)
                                                      `(remove-keywords ,bytes)))))
                                attributes))
                 
                 (,(intern (concatenate 'string "MAKE-" (string name)))
                  ,@(mapcan (lambda (name) (list (intern (string name) "KEYWORD") name))
                            attr-struct-names)))))))))