Skip to content

Instantly share code, notes, and snippets.

@death
Created December 31, 2009 22:31
Show Gist options
  • Save death/266945 to your computer and use it in GitHub Desktop.
Save death/266945 to your computer and use it in GitHub Desktop.
python.struct hack in Common Lisp
(defpackage #:pack
(:use #:cl #:alexandria)
(:export
#:pack
#:pack-into
#:unpack
#:calc-size
#:compile-struct-string
#:pack*
#:unpack*
#:struct-stream-protocol))
(in-package #:pack)
(defvar *offset*)
(defvar *reader*)
(defvar *writer*)
(declaim (inline write-octet))
(defun write-octet (octet)
(funcall *writer* octet))
(declaim (inline read-octet))
(defun read-octet ()
(funcall *reader*))
(declaim (inline offset))
(defun offset ()
*offset*)
(declaim (inline (setf offset)))
(defun (setf offset) (new-value)
(setf *offset* new-value))
(defmacro write-unsigned-le (value size)
(once-only (value)
`(progn
,@(loop for i from 0 below (* 8 size) by 8
collect `(write-octet (ldb (byte 8 ,i) ,value)))
(incf (offset) ,size))))
(defmacro read-unsigned-le (size)
(with-gensyms (value)
`(let ((,value 0))
,@(loop for i from 0 below (* 8 size) by 8
collect `(setf (ldb (byte 8 ,i) ,value) (read-octet)))
(incf (offset) ,size)
,value)))
(defmacro write-unsigned-be (value size)
(once-only (value)
`(progn
,@(loop for i from (* (1- size) 8) downto 0 by 8
collect `(write-octet (ldb (byte 8 ,i) ,value)))
(incf (offset) ,size))))
(defmacro read-unsigned-be (size)
(with-gensyms (value)
`(let ((,value 0))
,@(loop for i from (* (1- size) 8) downto 0 by 8
collect `(setf (ldb (byte 8 ,i) ,value) (read-octet)))
(incf (offset) ,size)
,value)))
(defun char-to-byte (char-or-byte)
(if (characterp char-or-byte)
(char-code char-or-byte)
char-or-byte))
(defun byte-to-char (char-or-byte)
(if (integerp char-or-byte)
(code-char char-or-byte)
char-or-byte))
(defun bool-to-byte (bool)
(if bool 1 0))
(defun byte-to-bool (byte)
(not (zerop byte)))
(declaim (inline signed-to-unsigned))
(defun signed-to-unsigned (value size)
(if (minusp value)
(+ value (expt 2 (* 8 size)))
value))
(declaim (inline unsigned-to-signed))
(defun unsigned-to-signed (value size)
(let ((max-signed (expt 2 (1- (* 8 size))))
(to-subtract (expt 2 (* 8 size))))
(if (>= value max-signed)
(- value to-subtract)
value)))
(defmacro write-signed-le (value size)
`(write-unsigned-le (signed-to-unsigned ,value ,size) ,size))
(defmacro write-signed-be (value size)
`(write-unsigned-be (signed-to-unsigned ,value ,size) ,size))
(defmacro read-signed-le (size)
`(unsigned-to-signed (read-unsigned-le ,size) ,size))
(defmacro read-signed-be (size)
`(unsigned-to-signed (read-unsigned-be ,size) ,size))
(declaim (inline divisible-by-p))
(defun divisible-by-p (n d)
(zerop (mod n d)))
(declaim (inline write-pad))
(defun write-pad (size)
(loop repeat size do (write-octet 0))
(incf (offset) size))
(defun read-pad (size)
(loop repeat size do (read-octet))
(incf (offset) size)
(values))
(defun read-fixlen-string (size)
(let ((string (make-string size)))
(dotimes (i size)
(setf (char string i) (code-char (read-octet))))
(incf (offset) size)
string))
(defun write-fixlen-string (value size)
(dotimes (i size)
(write-octet
(if (>= i (length value))
0
(char-code (char value i)))))
(incf (offset) size))
(defun read-pascal-string (size)
(let ((string (make-array (1- size) :fill-pointer 0 :element-type 'character))
(n (1- (read-octet))))
(incf (offset))
(dotimes (i (1- size))
(let ((c (read-octet)))
(when (< i n)
(vector-push (code-char c) string))))
(incf (offset) (1- size))
string))
(defun write-pascal-string (value size)
(write-octet (1+ (length value)))
(incf (offset))
(write-fixlen-string value (1- size)))
(defun write-float-le (value)
(write-signed-le (sb-kernel:single-float-bits value) 4))
(defun write-float-be (value)
(write-signed-be (sb-kernel:single-float-bits value) 4))
(defun read-float-le ()
(sb-kernel:make-single-float (read-signed-le 4)))
(defun read-float-be ()
(sb-kernel:make-single-float (read-signed-be 4)))
(defun write-double-le (value)
(write-unsigned-le (sb-kernel:double-float-low-bits value) 4)
(write-signed-le (sb-kernel:double-float-high-bits value) 4))
(defun write-double-be (value)
(write-signed-be (sb-kernel:double-float-high-bits value) 4)
(write-unsigned-be (sb-kernel:double-float-low-bits value) 4))
(defun read-double-le ()
(let ((lo (read-unsigned-le 4))
(hi (read-signed-le 4)))
(sb-kernel:make-double-float hi lo)))
(defun read-double-be ()
(let ((hi (read-signed-be 4))
(lo (read-unsigned-be 4)))
(sb-kernel:make-double-float hi lo)))
(defvar *pack-args* '())
(declaim (inline pack-arg))
(defun pack-arg ()
(if (null *pack-args*)
(error "Not enough pack arguments.")
(pop *pack-args*)))
(defun compile-struct-string (string)
(with-input-from-string (in string)
(flet ((consume () (read-char in)))
(let ((n nil)
(pack '())
(unpack '())
(c (consume))
(size 0))
(multiple-value-bind (byte-order size/alignment)
(case c
(#\@ (values :little-endian :native))
((#\= #\<) (values :little-endian :standard))
((#\! #\>) (values :big-endian :standard)))
(if (or byte-order size/alignment)
(setf c (consume))
(setf byte-order :little-endian size/alignment :native))
(loop
(let ((d (digit-char-p c)))
(cond (d
(if (null n)
(setf n d)
(setf n (+ (* n 10) d))))
(t (let ((n (or n 1)))
(macrolet ((packer (&body forms)
`(push `(loop repeat ,n doing ,',@forms) pack))
(unpacker (&body forms)
`(push `(loop repeat ,n collecting (progn ,',@forms)) unpack))
(maybe-pad (n)
`(when (eq :native size/alignment)
(let ((to-pad (mod size ,n)))
(unless (zerop to-pad)
(incf size to-pad)
(push `(progn (write-pad ,to-pad)) pack)
(push `(progn (read-pad ,to-pad) '()) unpack))))))
(ecase c
(#\x
(incf size n)
(push `(progn (write-pad ,n)) pack)
(push `(progn (read-pad ,n) '()) unpack))
(#\c
(incf size n)
(packer (write-unsigned (char-to-byte (pack-arg)) 1))
(unpacker (byte-to-char (read-unsigned 1))))
(#\b
(incf size n)
(packer (write-signed (pack-arg) 1))
(unpacker (read-signed 1)))
(#\B
(incf size n)
(packer (write-unsigned (pack-arg) 1))
(unpacker (read-unsigned 1)))
(#\?
(incf size n)
(packer (write-unsigned (bool-to-byte (pack-arg)) 1))
(unpacker (byte-to-bool (read-unsigned 1))))
(#\h
(maybe-pad 2)
(incf size (* 2 n))
(packer (write-signed (pack-arg) 2))
(unpacker (read-signed 2)))
(#\H
(maybe-pad 2)
(incf size (* 2 n))
(packer (write-unsigned (pack-arg) 2))
(unpacker (read-unsigned 2)))
((#\i #\l #\P)
(maybe-pad 4)
(incf size (* 4 n))
(packer (write-signed (pack-arg) 4))
(unpacker (read-signed 4)))
((#\I #\L)
(maybe-pad 4)
(incf size (* 4 n))
(packer (write-unsigned (pack-arg) 4))
(unpacker (read-unsigned 4)))
(#\q
(maybe-pad 8)
(incf size (* 8 n))
(packer (write-signed (pack-arg) 8))
(unpacker (read-signed 8)))
(#\Q
(maybe-pad 8)
(incf size (* 8 n))
(packer (write-unsigned (pack-arg) 8))
(unpacker (read-unsigned 8)))
(#\f
(maybe-pad 4)
(incf size (* 4 n))
(packer (write-float (pack-arg)))
(unpacker (read-float)))
(#\d
(maybe-pad 8)
(incf size (* 8 n))
(packer (write-double (pack-arg)))
(unpacker (read-double)))
(#\s
(incf size n)
(push `(write-fixlen-string (pack-arg) ,n) pack)
(push `(list (read-fixlen-string ,n)) unpack))
(#\p
(incf size n)
(push `(write-pascal-string (pack-arg) ,n) pack)
(push `(list (read-pascal-string ,n)) unpack)))))
(setf n nil))))
(handler-case
(setf c (consume))
(error () (return))))
(flet ((using-byte-order (forms)
(ecase byte-order
(:little-endian
`(macrolet ((write-unsigned (value size) `(write-unsigned-le ,value ,size))
(write-signed (value size) `(write-signed-le ,value ,size))
(read-unsigned (size) `(read-unsigned-le ,size))
(read-signed (size) `(read-signed-le ,size))
(write-double (value) `(write-double-le ,value))
(read-double () `(read-double-le))
(write-float (value) `(write-float-le ,value))
(read-float () `(read-float-le)))
,@forms))
(:big-endian
`(macrolet ((write-unsigned (value size) `(write-unsigned-be ,value ,size))
(write-signed (value size) `(write-signed-be ,value ,size))
(read-unsigned (size) `(read-unsigned-be ,size))
(read-signed (size) `(read-signed-be ,size))
(write-double (value) `(write-double-be ,value))
(read-double () `(read-double-be))
(write-float (value) `(write-float-be ,value))
(read-float () `(read-float-be)))
,@forms)))))
(list :pack (compile nil `(lambda () ,(using-byte-order (nreverse pack))))
:unpack (compile nil `(lambda () ,(using-byte-order `((nconc ,@(nreverse unpack))))))
:size size)))))))
(defgeneric struct-stream-protocol (stream))
(defmethod struct-stream-protocol ((stream stream))
(values
(lambda () (read-byte stream))
(lambda (octet) (write-byte octet stream))))
(defmethod struct-stream-protocol ((vector vector))
(values
(let ((i 0))
(lambda ()
(prog1 (aref vector i)
(incf i))))
(let ((i 0))
(lambda (octet)
(setf (aref vector i) octet)
(incf i)))))
(defun pack* (compiled stream &rest args)
(when (null stream)
(setf stream (make-array (getf compiled :size) :element-type '(unsigned-byte 8))))
(multiple-value-bind (reader writer)
(struct-stream-protocol stream)
(let ((*pack-args* args)
(*offset* 0)
(*reader* reader)
(*writer* writer))
(funcall (getf compiled :pack))))
stream)
(defun pack (string &rest args)
(apply #'pack* (compile-struct-string string) nil args))
(define-compiler-macro pack (&whole form string &rest args)
(if (stringp string)
`(pack* (load-time-value (compile-struct-string ,string)) nil ,@args)
form))
(defun pack-into (string stream &rest args)
(apply #'pack* (compile-struct-string string) stream args))
(define-compiler-macro pack-into (&whole form string stream &rest args)
(if (stringp string)
`(pack* (load-time-value (compile-struct-string ,string)) ,stream ,@args)
form))
(defun unpack* (compiled stream)
(multiple-value-bind (reader writer)
(struct-stream-protocol stream)
(let ((*offset* 0)
(*reader* reader)
(*writer* writer))
(funcall (getf compiled :unpack)))))
(defun unpack (string stream)
(unpack* (compile-struct-string string) stream))
(define-compiler-macro unpack (&whole form string stream)
(if (stringp string)
`(unpack* (load-time-value (compile-struct-string ,string)) ,stream)
form))
(defun calc-size (string)
(getf (compile-struct-string string) :size))
(define-compiler-macro calc-size (&whole form string)
(if (stringp string)
(getf (compile-struct-string string) :size)
form))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment