public
Created

defbinstruct first try

  • Download Gist
gistfile1.lisp
Common Lisp
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57
(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)))))))))

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.