Skip to content

Use portable ieee-floats and conform to specs for extensions and strings. #21

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
Islam0mar wants to merge 5 commits into
base: master
Choose a base branch
from
Open

Use portable ieee-floats and conform to specs for extensions and strings. #21

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
4848562
Use portable ieee-floats + hton/ntoh
Islam0mar Jan 20, 2023
0220330
fix symbols package
Islam0mar Jan 21, 2023
75941fe
cleanup
Islam0mar Jan 21, 2023
4cc7fd9
cleanup
Islam0mar Jan 21, 2023
6dd0a8a
conform to msgpack specs
Islam0mar Jan 21, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion cl-messagepack.asd
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -24,7 +24,7 @@

(asdf:defsystem #:cl-messagepack
:serial t
:depends-on (:flexi-streams :babel :closer-mop)
:depends-on (:flexi-streams :babel :closer-mop :ieee-floats)
:description "A Common-Lisp implementation of Message Pack serialization."
:author "Miron Brezuleanu"
:license "Simplified BSD License"
Expand Down
144 changes: 89 additions & 55 deletions cl-messagepack.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -188,38 +188,17 @@
(encode-string (symbol-name data) stream))

(defun encode-string (data stream)
(encode-raw-bytes (babel:string-to-octets data) stream))

#+sbcl (defun sbcl-encode-float (data stream &optional drop-prefix)
(cond ((equal (type-of data) 'single-float)
(unless drop-prefix
(write-byte #xca stream))
(store-big-endian (sb-kernel:single-float-bits data) stream 4))
((equal (type-of data) 'double-float)
(unless drop-prefix
(write-byte #xcb stream))
(store-big-endian (sb-kernel:double-float-high-bits data) stream 4)
(store-big-endian (sb-kernel:double-float-low-bits data) stream 4))
(T
(error "~s is not a float" data))))

#+ccl (defun ccl-encode-double-float (data stream &optional drop-prefix)
(cond ((equal (type-of data) 'single-float)
(error "No cl-messagepack support for single precision floats in CCL."))
((equal (type-of data) 'double-float)
(unless drop-prefix
(write-byte #xcb stream))
(multiple-value-bind (hi lo)
(ccl::double-float-bits data)
(store-big-endian hi stream 4)
(store-big-endian lo stream 4)))
(T
(error "~s is not a float" data))))

(defun encode-float (data stream &optional drop-prefix)
(or #+sbcl (sbcl-encode-float data stream drop-prefix)
#+ccl (ccl-encode-double-float data stream drop-prefix)
#-(or sbcl ccl) (error "No floating point support yet.")))
(setf data (babel:string-to-octets data))
(encode-sequence-length data stream #xa0 31 #xd9 #xda #xdb)
(write-sequence data stream))

(defun encode-float (data stream)
(cond ((equal (type-of data) 'single-float)
(write-byte #xca stream)
(store-big-endian (ieee-floats:encode-float32 data) stream 4))
((equal (type-of data) 'double-float)
(write-byte #xcb stream)
(store-big-endian (ieee-floats:encode-float64 data) stream 8))))

(defun encode-each (data stream)
(cond ((hash-table-p data)
Expand All @@ -245,20 +224,20 @@
(t (error "Not sequence or hash table."))))

(defun encode-sequence-length (data stream
short-prefix short-length
fixed-prefix fixed-length
typecode-8
typecode-16 typecode-32)
(let ((len (cond ((hash-table-p data) (hash-table-count data))
((plistp data) (let ((ln (length data)))
(if (evenp ln)
(/ ln 2)
(error "Malformed plist ~s. Length should be even." data))))
(t (length data)))))
(cond ((and (<= 0 len short-length) (plusp short-length))
(write-byte (+ short-prefix len) stream))
((and (<= 0 len #xff) (zerop short-length))
(write-byte short-prefix stream)
(write-byte len stream)
(store-big-endian len stream 1))
(cond ((and (<= 0 len fixed-length) (plusp fixed-length))
(write-byte (+ fixed-prefix len) stream))
((and (<= 0 len #xff) typecode-8)
(write-byte typecode-8 stream)
(write-byte len stream))
((<= 0 len 65535)
(write-byte typecode-16 stream)
(store-big-endian len stream 2))
Expand All @@ -267,15 +246,15 @@
(store-big-endian len stream 4)))))

(defun encode-hash (data stream)
(encode-sequence-length data stream #x80 15 #xde #xdf)
(encode-sequence-length data stream #x80 15 nil #xde #xdf)
(encode-each data stream))

(defun encode-array (data stream)
(encode-sequence-length data stream #x90 15 #xdc #xdd)
(encode-sequence-length data stream #x90 15 nil #xdc #xdd)
(encode-each data stream))

(defun encode-raw-bytes (data stream)
(encode-sequence-length data stream #xa0 31 #xda #xdb)
(encode-sequence-length data stream #x0 0 #xc4 #xc5 #xc6)
(write-sequence data stream))

(defun encode-integer (data stream)
Expand Down Expand Up @@ -380,14 +359,9 @@
((= #xc2 byte)
(if *use-false* :false nil))
((= #xca byte)
(or #+sbcl (sb-kernel:make-single-float (ub32->sb32 (load-big-endian stream 4)))
#-(or sbcl) (error "No floating point support yet.")))
(ieee-floats:decode-float32 (load-big-endian stream 4)))
((= #xcb byte)
(or #+sbcl (sb-kernel:make-double-float (ub32->sb32 (load-big-endian stream 4))
(load-big-endian stream 4))
#+ccl (ccl::double-float-from-bits (load-big-endian stream 4)
(load-big-endian stream 4))
#-(or sbcl ccl) (error "No floating point support yet.")))
(ieee-floats:decode-float64 (load-big-endian stream 8)))
((= 5 (ldb (byte 3 5) byte))
(decode-string (ldb (byte 5 0) byte) stream))
((= #xd9 byte)
Expand Down Expand Up @@ -588,6 +562,30 @@
(parse-big-endian bytes)
bytes))))

(defun encode-fix-ext (fixext-byte type obj stream)
(write-byte fixext-byte stream)
(write-byte type stream)
(write-sequence obj stream))

(defun encode-ext8 (len type obj stream)
(write-byte #xC7 stream)
(write-byte len stream)
(write-byte type stream)
(write-sequence obj stream))

(defun encode-ext16 (len type obj stream)
(write-byte #xC8 stream)
(store-big-endian len stream 2)
(write-byte type stream)
(write-sequence obj stream))

(defun encode-ext32 (len type obj stream)
(write-byte #xC9 stream)
(store-big-endian len stream 4)
(write-byte type stream)
(write-sequence obj stream))


(defun try-encode-ext-type (obj stream)
(let ((ext-type (find (class-of obj) *extended-types*
:test #'eq
Expand All @@ -600,14 +598,50 @@
(encode-integer id s))
id))
(len (length bytes)))
;; TODO: in theory the ID might be longer than 256 bytes...
;; in theory the ID might be longer than 256 bytes...
;; (encode-sequence-length bytes stream #xc7 0 #xc8 #xc9)
;; but we need the type inbetween.
(assert (<= 0 len #xff))
(write-byte #xc7 stream)
(write-byte len stream)
(write-byte (type-number ext-type) stream)
(write-sequence bytes stream))
(cond ((= len 1)
(encode-fix-ext #xd4
(type-number ext-type)
bytes
stream))
((= len 2)
(encode-fix-ext #xd5
(type-number ext-type)
bytes
stream))
((= len 4)
(encode-fix-ext #xd6
(type-number ext-type)
bytes
stream))
((= len 8)
(encode-fix-ext #xd7
(type-number ext-type)
bytes
stream))
((= len 16)
(encode-fix-ext #xd8
(type-number ext-type)
bytes
stream))
((< len 256)
(encode-ext8 len
(type-number ext-type)
bytes
stream))
((< len 65536)
(encode-ext16 len
(type-number ext-type)
bytes
stream))
((< len 4294967296)
(encode-ext32 len
(type-number ext-type)
bytes
stream))
(t (error "array length is too large."))))
T)))


Expand Down
26 changes: 16 additions & 10 deletions tests.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -57,8 +57,8 @@
(test floating-point
"Test encoding of single and double precision floating point
numbers."
#+sbcl (is (equalp #(#xCA #x3F #x80 #x00 #x00) (mpk:encode 1.0s0)))
#+sbcl (is (equalp #(#xCA #xBF #x80 #x00 #x00) (mpk:encode -1.0s0)))
(is (equalp #(#xCA #x3F #x80 #x00 #x00) (mpk:encode 1.0s0)))
(is (equalp #(#xCA #xBF #x80 #x00 #x00) (mpk:encode -1.0s0)))
(is (equalp #(#xCB #x3F #xF0 #x00 #x00 #x00 #x00 #x00 #x00) (mpk:encode 1.0d0)))
(is (equalp #(#xCB #xBF #xF0 #x00 #x00 #x00 #x00 #x00 #x00) (mpk:encode -1.0d0))))

Expand All @@ -68,7 +68,7 @@ since I am interested in using msgpack as a binary JSON). Use strings
of various lengths to make sure string length is encoded properly."
(is (equalp #(#xAB #x54 #x65 #x73 #x74 #x20 #x73 #x74 #x72 #x69 #x6E #x67)
(mpk:encode "Test string")))
(is (equalp #(#xDA #x00 #x3C #x73 #x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E #x67 #x73
(is (equalp #(#xD9 #x3C #x73 #x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E #x67 #x73
#x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E
#x67 #x73 #x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72
#x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E #x67)
Expand Down Expand Up @@ -149,8 +149,14 @@ encode properly."
(let ((mpk:*extended-types*
(mpk:define-extension-types
'(7 type1))))
(is (equalp #(#xC7 #x01 #x07 #x09)
(mpk:encode (make-instance 'type1 'messagepack-sym:id 9))))))
(is (equalp #(#xd4 #x07 #x09)
(mpk:encode (make-instance 'type1 'messagepack-sym:id #(9)))))
(is (equalp #(#xd5 #x07 #x01 #x02)
(mpk:encode (make-instance 'type1 'messagepack-sym:id #(1 2)))))
(is (equalp #(#xc7 #x03 #x07 #x01 #x02 #x03)
(mpk:encode (make-instance 'type1 'messagepack-sym:id #(1 2 3)))))
(is (equalp #(#xd6 #x07 #x01 #x02 #x03 #x04)
(mpk:encode (make-instance 'type1 'messagepack-sym:id #(1 2 3 4)))))))

(test decoding-integers
"Test that (equalp (decode (encode data)) data) for integers (that
Expand All @@ -168,12 +174,12 @@ encode properly."

(test decoding-floats
"Test that (equalp (decode (encode data)) data) for floats."
#+ (or sbcl ccl) (is (eql 100d0 (mpk:decode (mpk:encode 100d0))))
#+ (or sbcl ccl) (is (eql -100d0 (mpk:decode (mpk:encode -100d0))))
#+ (or sbcl ccl) (is (eql -1.2345678901234567e19
(is (eql 100d0 (mpk:decode (mpk:encode 100d0))))
(is (eql -100d0 (mpk:decode (mpk:encode -100d0))))
(is (eql -1.2345678901234567e19
(mpk:decode (mpk:encode -1.2345678901234567e19))))
#+ sbcl (is (eql 102s0 (mpk:decode (mpk:encode 102s0))))
#+ sbcl (is (eql -102s0 (mpk:decode (mpk:encode -102s0)))))
(is (eql 102s0 (mpk:decode (mpk:encode 102s0))))
(is (eql -102s0 (mpk:decode (mpk:encode -102s0)))))

(test decoding-strings
"Test that (equalp (decode (encode data)) data) holds for strings."
Expand Down