├── .gitignore ├── Makefile ├── README.md ├── UNLICENSE ├── bitpack-tests.el └── bitpack.el /.gitignore: -------------------------------------------------------------------------------- 1 | bitpack.elc 2 | bitpack-tests.elc 3 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .POSIX: 2 | EMACS = emacs 3 | 4 | compile: bitpack.elc bitpack-tests.elc 5 | 6 | bitpack.elc: bitpack.el 7 | bitpack-tests.elc: bitpack-tests.el bitpack.elc 8 | 9 | clean: 10 | rm -f bitpack.elc bitpack-tests.elc 11 | 12 | check: bitpack-tests.elc 13 | $(EMACS) -batch -Q -L . -l bitpack-tests.elc -f ert-run-tests-batch 14 | 15 | bench: bitpack-tests.elc 16 | $(EMACS) -batch -Q -L . -l bitpack-tests.elc -f bitpack-benchmark 17 | 18 | .SUFFIXES: .el .elc 19 | .el.elc: 20 | $(EMACS) -batch -Q -L . -f batch-byte-compile $< 21 | 22 | 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # bitpack: an Emacs Lisp structure packing library 2 | 3 | `bitpack` is similar to the built-in `bindat` package. However, this 4 | package can encode IEEE 754 floating point values, both single 5 | (32-bit) and double precision (64-bit). 6 | 7 | In Emacs 26.1 on modern x86-64 hardware, it stores ~290k double 8 | precision floats per second, and loads them at ~1.3M per second. 9 | 10 | Requires either: 11 | 12 | * Emacs 27 (any) 13 | * Emacs 24.3 through 26.x (64-bit or `--with-wide-int` 32-bit) 14 | 15 | Use `make check` to verify that your particular Emacs build works 16 | correctly with this package. 17 | 18 | ## API 19 | 20 | Rather than return and accept unibyte strings, each function operates 21 | on the current buffer. This buffer must not be multibyte (i.e. 22 | `set-buffer-multibyte` to nil). 23 | 24 | The `byte-order` argument can be `:>` (big endian) or `:<` little 25 | endian. 26 | 27 | ```el 28 | ;; Store floats 29 | (bitpack-store-f32 byte-order x) 30 | (bitpack-store-f64 byte-order x) 31 | 32 | ;; Store integers 33 | (bitpack-store-i8 x) 34 | (bitpack-store-i16 byte-order x) 35 | (bitpack-store-i32 byte-order x) 36 | (bitpack-store-i64 byte-order x) 37 | 38 | ;; Load floats 39 | (bitpack-load-f32 byte-order) 40 | (bitpack-load-f64 byte-order) 41 | 42 | ;; Load integers 43 | (bitpack-load-u8) 44 | (bitpack-load-s8) 45 | (bitpack-load-u16 byte-order) 46 | (bitpack-load-s16 byte-order) 47 | (bitpack-load-u32 byte-order) 48 | (bitpack-load-s32 byte-order) 49 | (bitpack-load-u64 byte-order) 50 | (bitpack-load-s64 byte-order) 51 | ``` 52 | 53 | When writing values, the sign doesn't matter. When reading values, the 54 | sign determines how the value is interpreted. 55 | 56 | ## Example 57 | 58 | Packing and unpacking floating a point value: 59 | 60 | ```el 61 | (with-temp-buffer 62 | (set-buffer-multibyte nil) 63 | (bitpack-store-f64 :> float-pi) 64 | (buffer-string)) 65 | ;; => "\x40\x09\x21\xfb\x54\x44\x2d\x18" 66 | 67 | (with-temp-buffer 68 | (set-buffer-multibyte nil) 69 | (save-excursion 70 | (insert #x40 #x09 #x21 #xfb #x54 #x44 #x2d #x18)) 71 | (bitpack-load-f64 :>)) 72 | ;; => 3.141592653589793 73 | ``` 74 | 75 | This writes a `middle-c.wav` file with three seconds of a middle C tone: 76 | 77 | ```el 78 | (with-temp-file "middle-c.wav" 79 | (set-buffer-multibyte nil) 80 | (let ((hz 44100) 81 | (seconds 3) 82 | (freq 261.6)) ;; middle C 83 | (insert "RIFF") 84 | (bitpack-store-i32 :< -1) ; file length 85 | (insert "WAVE") 86 | (insert "fmt ") 87 | (bitpack-store-i32 :< 16) ; struct size 88 | (bitpack-store-i16 :< 1) ; PCM 89 | (bitpack-store-i16 :< 1) ; mono 90 | (bitpack-store-i32 :< hz) ; sample rate (i.e. 44.1 kHz) 91 | (bitpack-store-i32 :< (* 2 hz)) ; byte rate 92 | (bitpack-store-i16 :< 2) ; block size 93 | (bitpack-store-i16 :< 16) ; bits per sample 94 | (insert "data") 95 | (bitpack-store-i32 :< -1) ; byte length 96 | (dotimes (i (* seconds hz)) 97 | (let* ((time (/ i (float hz))) 98 | (value (sin (* time freq 2.0 float-pi))) 99 | (sample (* 32767 value))) 100 | (bitpack-store-i16 :< (round sample)))))) 101 | ``` 102 | -------------------------------------------------------------------------------- /UNLICENSE: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to 25 | -------------------------------------------------------------------------------- /bitpack-tests.el: -------------------------------------------------------------------------------- 1 | ;;; bitpack-tests.el -- tests for bitpack -*- lexical-binding: t; -*- 2 | 3 | ;;; Code: 4 | 5 | (require 'ert) 6 | (require 'bitpack) 7 | 8 | (ert-deftest bitpack-f64 () 9 | (dolist (byte-order '(:> :<)) 10 | ;; Positive NaN 11 | (with-temp-buffer 12 | (bitpack-store-f64 byte-order +0.0e+NaN) 13 | (setf (point) (point-min)) 14 | (let ((result (bitpack-load-f64 byte-order))) 15 | (should (isnan result)) 16 | (should (> (copysign 1.0 result) 0)))) 17 | ;; Negative NaN 18 | (with-temp-buffer 19 | (bitpack-store-f64 byte-order -0.0e+NaN) 20 | (setf (point) (point-min)) 21 | (let ((result (bitpack-load-f64 byte-order))) 22 | (should (isnan result)) 23 | (should (< (copysign 1.0 result) 0)))) 24 | ;; Positive Infinity 25 | (with-temp-buffer 26 | (bitpack-store-f64 byte-order +1.0e+INF) 27 | (setf (point) (point-min)) 28 | (let ((result (bitpack-load-f64 byte-order))) 29 | (should (= 1.0e+INF result)))) 30 | ;; Negative Infinity 31 | (with-temp-buffer 32 | (bitpack-store-f64 byte-order -1.0e+INF) 33 | (setf (point) (point-min)) 34 | (let ((result (bitpack-load-f64 byte-order))) 35 | (should (= -1.0e+INF result))))) 36 | ;; Check specific known value 37 | (with-temp-buffer 38 | (bitpack-store-f64 :> float-pi) 39 | (should (equal (buffer-string) 40 | (string #x40 #x09 #x21 #xfb #x54 #x44 #x2d #x18)))) 41 | ;; Check many round trips 42 | (let ((floats (list float-pi))) 43 | (dotimes (_ 10000) 44 | (push (cl-random 1.0) floats)) 45 | (dotimes (_ 1000) 46 | (push (cl-random 1000.0) floats)) 47 | (dotimes (_ 1000) 48 | (push (cl-random 1000000.0) floats)) 49 | (dotimes (_ 10000) 50 | (push (- (cl-random 1.0)) floats)) 51 | (dotimes (_ 1000) 52 | (push (- (cl-random 1000.0)) floats)) 53 | (dotimes (_ 1000) 54 | (push (- (cl-random 1000000.0)) floats)) 55 | (dolist (byte-order '(:> :<)) 56 | (with-temp-buffer 57 | (set-buffer-multibyte nil) 58 | (dolist (float floats) 59 | (bitpack-store-f64 byte-order float)) 60 | (setf (point) (point-min)) 61 | (dolist (float floats) 62 | (should (eql (bitpack-load-f64 byte-order) float))))))) 63 | 64 | (ert-deftest bitpack-f32 () 65 | (dolist (byte-order '(:> :<)) 66 | ;; Positive NaN 67 | (with-temp-buffer 68 | (bitpack-store-f32 byte-order +0.0e+NaN) 69 | (setf (point) (point-min)) 70 | (let ((result (bitpack-load-f32 byte-order))) 71 | (should (isnan result)) 72 | (should (> (copysign 1.0 result) 0)))) 73 | ;; Negative NaN 74 | (with-temp-buffer 75 | (bitpack-store-f32 byte-order -0.0e+NaN) 76 | (setf (point) (point-min)) 77 | (let ((result (bitpack-load-f32 byte-order))) 78 | (should (isnan result)) 79 | (should (< (copysign 1.0 result) 0)))) 80 | ;; Positive Infinity 81 | (with-temp-buffer 82 | (bitpack-store-f32 byte-order +1.0e+INF) 83 | (setf (point) (point-min)) 84 | (let ((result (bitpack-load-f32 byte-order))) 85 | (should (= 1.0e+INF result)))) 86 | ;; Negative Infinity 87 | (with-temp-buffer 88 | (bitpack-store-f32 byte-order -1.0e+INF) 89 | (setf (point) (point-min)) 90 | (let ((result (bitpack-load-f32 byte-order))) 91 | (should (= -1.0e+INF result))))) 92 | ;; Check specific known value 93 | (with-temp-buffer 94 | (bitpack-store-f32 :> float-pi) 95 | (should (equal (buffer-string) (string #x40 #x49 #x0f #xdb)))) 96 | ;; Check integral values 97 | (let ((floats ())) 98 | (dotimes (_ 1000) 99 | (push (float (cl-random 1000000)) floats)) 100 | (dotimes (_ 1000) 101 | (push (- (float (cl-random 1000000))) floats)) 102 | (dolist (byte-order '(:> :<)) 103 | (with-temp-buffer 104 | (set-buffer-multibyte nil) 105 | (dolist (float floats) 106 | (bitpack-store-f32 byte-order float)) 107 | (setf (point) (point-min)) 108 | (dolist (float floats) 109 | (should (eql (bitpack-load-f32 byte-order) float))))))) 110 | 111 | (defun random-integers (min max n) 112 | "Return N random integers between MIN (inclusive) and MAX (exclusive)." 113 | (let ((list ())) 114 | (dotimes (_ n) 115 | (push (+ (cl-random (- max min)) min) list)) 116 | list)) 117 | 118 | (defun drive (encode decode min max n &optional dir) 119 | (let ((list (random-integers min max n))) 120 | (if dir 121 | (with-temp-buffer 122 | (save-excursion 123 | (dolist (x list) 124 | (funcall encode dir x))) 125 | (dolist (x list) 126 | (should (eql (funcall decode dir) x)))) 127 | (with-temp-buffer 128 | (save-excursion 129 | (dolist (x list) 130 | (funcall encode x))) 131 | (dolist (x list) 132 | (should (eql (funcall decode) x))))))) 133 | 134 | (ert-deftest bitpack-u8 () 135 | (drive #'bitpack-store-i8 #'bitpack-load-u8 0 #x100 200)) 136 | 137 | (ert-deftest bitpack-s8 () 138 | (drive #'bitpack-store-i8 #'bitpack-load-s8 (- #x80) #x80 200)) 139 | 140 | (ert-deftest bitpack-u16 () 141 | (let ((min 0) 142 | (max #x10000) 143 | (n 10000)) 144 | (drive #'bitpack-store-i16 #'bitpack-load-u16 min max n :>) 145 | (drive #'bitpack-store-i16 #'bitpack-load-u16 min max n :<))) 146 | 147 | (ert-deftest bitpack-s16 () 148 | (let ((min (- #x8000)) 149 | (max #x8000) 150 | (n 10000)) 151 | (drive #'bitpack-store-i16 #'bitpack-load-s16 min max n :>) 152 | (drive #'bitpack-store-i16 #'bitpack-load-s16 min max n :<))) 153 | 154 | (ert-deftest bitpack-u32 () 155 | (let ((min 0) 156 | (max #x100000000) 157 | (n 10000)) 158 | (drive #'bitpack-store-i32 #'bitpack-load-u32 min max n :>) 159 | (drive #'bitpack-store-i32 #'bitpack-load-u32 min max n :<))) 160 | 161 | (ert-deftest bitpack-s32 () 162 | (let ((min (- #x80000000)) 163 | (max #x80000000) 164 | (n 10000)) 165 | (drive #'bitpack-store-i32 #'bitpack-load-s32 min max n :>) 166 | (drive #'bitpack-store-i32 #'bitpack-load-s32 min max n :<))) 167 | 168 | (ert-deftest bitpack-u64 () 169 | (let ((min 0) 170 | (max most-positive-fixnum) 171 | (n 10000)) 172 | (drive #'bitpack-store-i64 #'bitpack-load-u64 min max n :>) 173 | (drive #'bitpack-store-i64 #'bitpack-load-u64 min max n :<))) 174 | 175 | (ert-deftest bitpack-s64 () 176 | (let ((min most-negative-fixnum) 177 | (max most-positive-fixnum) 178 | (n 10000)) 179 | (drive #'bitpack-store-i64 #'bitpack-load-s64 min max n :>) 180 | (drive #'bitpack-store-i64 #'bitpack-load-s64 min max n :<))) 181 | 182 | (defun single-64 (decode dir x) 183 | (with-temp-buffer 184 | (save-excursion 185 | (bitpack-store-i64 dir x)) 186 | (eql (funcall decode dir) x))) 187 | 188 | (ert-deftest bitpack-64-validate () 189 | (should (single-64 #'bitpack-load-u64 :> most-positive-fixnum)) 190 | (should (single-64 #'bitpack-load-u64 :< most-positive-fixnum)) 191 | (should (single-64 #'bitpack-load-s64 :> most-negative-fixnum)) 192 | (should (single-64 #'bitpack-load-s64 :< most-negative-fixnum)) 193 | (should (single-64 #'bitpack-load-s64 :> -1)) 194 | (should (single-64 #'bitpack-load-s64 :< -1)) 195 | (unless (fboundp 'bignump) 196 | (should-error (single-64 #'bitpack-load-u64 :< -1)) 197 | (should-error (single-64 #'bitpack-load-u64 :< most-negative-fixnum)) 198 | (with-temp-buffer 199 | (insert #x80 0 0 0 0 0 0 0) 200 | (should-error (bitpack-load-s64 :>))))) 201 | 202 | (defun bitpack-benchmark () 203 | (princ 204 | (format "bitpack-store-f64 %S\n" 205 | (benchmark-run 500 206 | (with-temp-buffer 207 | (dotimes (_ 1000) 208 | (bitpack-store-f64 :> float-pi)))))) 209 | (princ 210 | (format "bitpack-load-f64 %S\n" 211 | (with-temp-buffer 212 | (dotimes (_ 1000) 213 | (bitpack-store-f64 :> (cl-random 1000.0))) 214 | (benchmark-run 2500 215 | (setf (point) (point-min)) 216 | (while (< (point) (point-max)) 217 | (bitpack-load-f64 :>))))))) 218 | 219 | (provide 'bitpack-tests) 220 | 221 | ;;; bitpack-tests.el ends here 222 | -------------------------------------------------------------------------------- /bitpack.el: -------------------------------------------------------------------------------- 1 | ;;; bitpack.el --- Bit packing functions -*- lexical-binding: t; -*- 2 | 3 | ;; This is free and unencumbered software released into the public domain. 4 | 5 | ;; Author: Christopher Wellons 6 | ;; Version: 1.0.0 7 | ;; Created: 6 Apr 2019 8 | ;; Keywords: c, comm 9 | ;; Homepage: https://github.com/skeeto/bitpack 10 | ;; Package-Requires: ((emacs "24.3")) 11 | 12 | ;;; Commentary: 13 | 14 | ;; bitdat is similar to the built-in bindat package. However, this 15 | ;; package can encode IEEE 754 floating point values, both single 16 | ;; (32-bit) and double precision (64-bit). Requires a 64-bit build of 17 | ;; Emacs. 18 | 19 | ;; IEEE 754 NaN have a sign, and this library is careful to store that 20 | ;; sign when packing NaN values. So be mindful of negative NaN: 21 | 22 | ;; http://lists.gnu.org/archive/html/emacs-devel/2018-07/msg00816.html 23 | 24 | ;; NaNs are always stored in quiet form (i.e. non-signaling). 25 | 26 | ;; Ref: https://stackoverflow.com/a/14955046 27 | 28 | ;;; Code: 29 | 30 | (require 'cl-lib) 31 | 32 | ;; Store functions 33 | 34 | (defsubst bitpack--store-f32> (negp biased-exp mantissa) 35 | "Store a single precision float in buffer at point as big-endian. 36 | 37 | NEGP, BIASED-EXP and MANTISSA are the float components." 38 | (insert (if negp 39 | (logior #x80 (ash biased-exp -1)) 40 | (ash biased-exp -1)) 41 | (logior (% (ash mantissa -16) 128) 42 | (% (ash biased-exp 7) 256)) 43 | (% (ash mantissa -8) 256) 44 | (% mantissa 256))) 45 | 46 | (defsubst bitpack--store-f32< (negp biased-exp mantissa) 47 | "Store a single precision float in buffer at point as little-endian. 48 | 49 | NEGP, BIASED-EXP and MANTISSA are the float components." 50 | (insert (% mantissa 256) 51 | (% (ash mantissa -8) 256) 52 | (logior (% (ash mantissa -16) 128) 53 | (% (ash biased-exp 7) 256)) 54 | (if negp 55 | (logior #x80 (ash biased-exp -1)) 56 | (ash biased-exp -1)))) 57 | 58 | (defsubst bitpack--store-f64> (negp biased-exp mantissa) 59 | "Store a double precision float in buffer at point as big-endian. 60 | 61 | NEGP, BIASED-EXP and MANTISSA are the float components." 62 | (insert (if negp 63 | (logior #x80 (ash biased-exp -4)) 64 | (ash biased-exp -4)) 65 | (logior (% (ash mantissa -48) 16) 66 | (% (ash biased-exp 4) 256)) 67 | (% (ash mantissa -40) 256) 68 | (% (ash mantissa -32) 256) 69 | (% (ash mantissa -24) 256) 70 | (% (ash mantissa -16) 256) 71 | (% (ash mantissa -8) 256) 72 | (% mantissa 256))) 73 | 74 | (defsubst bitpack--store-f64< (negp biased-exp mantissa) 75 | "Store a double precision float in buffer at point as little-endian. 76 | 77 | NEGP, BIASED-EXP and MANTISSA are the float components." 78 | (insert (% mantissa 256) 79 | (% (ash mantissa -8) 256) 80 | (% (ash mantissa -16) 256) 81 | (% (ash mantissa -24) 256) 82 | (% (ash mantissa -32) 256) 83 | (% (ash mantissa -40) 256) 84 | (logior (% (ash mantissa -48) 16) 85 | (% (ash biased-exp 4) 256)) 86 | (if negp 87 | (logior #x80 (ash biased-exp -4)) 88 | (ash biased-exp -4)))) 89 | 90 | (defun bitpack-store-f32 (byte-order x) 91 | "Store single precision float X in buffer at point per BYTE-ORDER. 92 | 93 | BYTE-ORDER may be :> (big endian) or :< (little endian). The 94 | buffer should *not* be multibyte (`set-buffer-multibyte')." 95 | (let* ((frexp (frexp (abs x))) 96 | (fract (car frexp)) 97 | (exp (cdr frexp)) 98 | (negp (< (copysign 1.0 x) 0.0)) 99 | (biased-exp nil) 100 | (mantissa nil)) 101 | (cond ((isnan x) ; NaN 102 | (setf biased-exp #xff 103 | mantissa #xc00000)) 104 | ((> fract 1.0) ; infinity 105 | (setf biased-exp #xff 106 | mantissa 0)) 107 | ((= fract 0.0) ; zero 108 | (setf biased-exp 0 109 | mantissa 0)) 110 | ((setf biased-exp (+ exp 126) 111 | mantissa (round (ldexp fract 24))))) 112 | (cl-case byte-order 113 | (:> (bitpack--store-f32> negp biased-exp mantissa)) 114 | (:< (bitpack--store-f32< negp biased-exp mantissa))))) 115 | 116 | (defun bitpack-store-f64 (byte-order x) 117 | "Store double precision float X in buffer at point per BYTE-ORDER. 118 | 119 | BYTE-ORDER may be :> (big endian) or :< (little endian). The 120 | buffer should *not* be multibyte (`set-buffer-multibyte')." 121 | (let* ((frexp (frexp (abs x))) 122 | (fract (car frexp)) 123 | (exp (cdr frexp)) 124 | (negp (< (copysign 1.0 x) 0.0)) 125 | (biased-exp nil) 126 | (mantissa nil)) 127 | (cond ((isnan x) ; NaN 128 | (setf biased-exp #x7ff 129 | mantissa #xc000000000000)) 130 | ((> fract 1.0) ; infinity 131 | (setf biased-exp #x7ff 132 | mantissa 0)) 133 | ((= fract 0.0) ; zero 134 | (setf biased-exp 0 135 | mantissa 0)) 136 | ((setf biased-exp (+ exp 1022) 137 | mantissa (truncate (ldexp fract 53))))) 138 | (cl-case byte-order 139 | (:> (bitpack--store-f64> negp biased-exp mantissa)) 140 | (:< (bitpack--store-f64< negp biased-exp mantissa))))) 141 | 142 | (defun bitpack-store-i64 (byte-order x) 143 | "Store 64-bit integer X in buffer at point per BYTE-ORDER. 144 | 145 | BYTE-ORDER may be :> (big endian) or :< (little endian). The 146 | buffer should *not* be multibyte (`set-buffer-multibyte')." 147 | (cl-case byte-order 148 | (:> (insert (logand (ash x -56) #xff) 149 | (logand (ash x -48) #xff) 150 | (logand (ash x -40) #xff) 151 | (logand (ash x -32) #xff) 152 | (logand (ash x -24) #xff) 153 | (logand (ash x -16) #xff) 154 | (logand (ash x -8) #xff) 155 | (logand x #xff))) 156 | (:< (insert (logand x #xff) 157 | (logand (ash x -8) #xff) 158 | (logand (ash x -16) #xff) 159 | (logand (ash x -24) #xff) 160 | (logand (ash x -32) #xff) 161 | (logand (ash x -40) #xff) 162 | (logand (ash x -48) #xff) 163 | (logand (ash x -56) #xff))))) 164 | 165 | (defun bitpack-store-i32 (byte-order x) 166 | "Store 32-bit integer X in buffer at point per BYTE-ORDER. 167 | 168 | BYTE-ORDER may be :> (big endian) or :< (little endian). The 169 | buffer should *not* be multibyte (`set-buffer-multibyte')." 170 | (cl-case byte-order 171 | (:> (insert (logand (ash x -24) #xff) 172 | (logand (ash x -16) #xff) 173 | (logand (ash x -8) #xff) 174 | (logand x #xff))) 175 | (:< (insert (logand x #xff) 176 | (logand (ash x -8) #xff) 177 | (logand (ash x -16) #xff) 178 | (logand (ash x -24) #xff))))) 179 | 180 | (defun bitpack-store-i16 (byte-order x) 181 | "Store 16-bit integer X in buffer at point per BYTE-ORDER. 182 | 183 | BYTE-ORDER may be :> (big endian) or :< (little endian). The 184 | buffer should *not* be multibyte (`set-buffer-multibyte')." 185 | (cl-case byte-order 186 | (:> (insert (logand (ash x -8) #xff) 187 | (logand x #xff))) 188 | (:< (insert (logand x #xff) 189 | (logand (ash x -8) #xff))))) 190 | 191 | (defsubst bitpack-store-i8 (x) 192 | "Store 8-bit integer X in buffer at point. 193 | 194 | The buffer should *not* be multibyte (`set-buffer-multibyte')." 195 | (insert (logand x #xff))) 196 | 197 | ;; Load functions 198 | 199 | (defsubst bitpack--load-f32 (b0 b1 b2 b3) 200 | "Load single precision float from the given bytes. 201 | 202 | B0, B1, B2, B3 are the bytes making up the float. 203 | B0 contains the MSB." 204 | (let* ((negp (= #x80 (logand b0 #x80))) 205 | (exp (logand (logior (ash b0 1) (ash b1 -7)) #xff)) 206 | (mantissa (logior #x800000 207 | (ash (logand #x7f b1) 16) 208 | (ash b2 8) 209 | b3)) 210 | (result (if (= #xff exp) 211 | (if (= #x800000 mantissa) 212 | 1.0e+INF 213 | 0.0e+NaN) 214 | (ldexp (ldexp mantissa -24) (- exp 126))))) 215 | (if negp 216 | (- result) 217 | result))) 218 | 219 | (defsubst bitpack--load-f64 (b0 b1 b2 b3 b4 b5 b6 b7) 220 | "Load double precision float from the given bytes. 221 | 222 | B0, B1, B2, B3, B4, B5, B6, B7 are the bytes making up the float. 223 | B0 contains the MSB." 224 | (let* ((negp (= #x80 (logand b0 #x80))) 225 | (exp (logand (logior (ash b0 4) (ash b1 -4)) #x7ff)) 226 | (mantissa (logior #x10000000000000 227 | (ash (logand #xf b1) 48) 228 | (ash b2 40) 229 | (ash b3 32) 230 | (ash b4 24) 231 | (ash b5 16) 232 | (ash b6 8) 233 | b7)) 234 | (result (if (= #x7ff exp) 235 | (if (= #x10000000000000 mantissa) 236 | 1.0e+INF 237 | 0.0e+NaN) 238 | (ldexp (ldexp mantissa -53) (- exp 1022))))) 239 | (if negp 240 | (- result) 241 | result))) 242 | 243 | (defun bitpack-load-f32 (byte-order) 244 | "Load single precision float from buffer at point per BYTE-ORDER. 245 | 246 | BYTE-ORDER may be :> (big endian) or :< (little endian). The 247 | point will be left just after the loaded value." 248 | (let ((b0 (prog1 (char-after) (forward-char))) 249 | (b1 (prog1 (char-after) (forward-char))) 250 | (b2 (prog1 (char-after) (forward-char))) 251 | (b3 (prog1 (char-after) (forward-char)))) 252 | (cl-case byte-order 253 | (:> (bitpack--load-f32 b0 b1 b2 b3)) 254 | (:< (bitpack--load-f32 b3 b2 b1 b0))))) 255 | 256 | (defun bitpack-load-f64 (byte-order) 257 | "Load double precision float from buffer at point per BYTE-ORDER. 258 | 259 | BYTE-ORDER may be :> (big endian) or :< (little endian). The 260 | point will be left just after the loaded value." 261 | (let ((b0 (prog1 (char-after) (forward-char))) 262 | (b1 (prog1 (char-after) (forward-char))) 263 | (b2 (prog1 (char-after) (forward-char))) 264 | (b3 (prog1 (char-after) (forward-char))) 265 | (b4 (prog1 (char-after) (forward-char))) 266 | (b5 (prog1 (char-after) (forward-char))) 267 | (b6 (prog1 (char-after) (forward-char))) 268 | (b7 (prog1 (char-after) (forward-char)))) 269 | (cl-case byte-order 270 | (:> (bitpack--load-f64 b0 b1 b2 b3 b4 b5 b6 b7)) 271 | (:< (bitpack--load-f64 b7 b6 b5 b4 b3 b2 b1 b0))))) 272 | 273 | (defsubst bitpack-load-u8 () 274 | "Load unsigned 8-bit integer from buffer at point. 275 | 276 | The point will be left just after the loaded value." 277 | (prog1 (char-after) 278 | (forward-char))) 279 | 280 | (defsubst bitpack-load-s8 () 281 | "Load signed 8-bit integer from buffer at point. 282 | 283 | The point will be left just after the loaded value." 284 | (let ((b0 (prog1 (char-after) (forward-char)))) 285 | (if (> b0 #x7f) 286 | (logior -256 b0) 287 | b0))) 288 | 289 | (defun bitpack-load-u16 (byte-order) 290 | "Load unsigned 16-bit integer from buffer at point per BYTE-ORDER. 291 | 292 | BYTE-ORDER may be :> (big endian) or :< (little endian). The 293 | point will be left just after the loaded value." 294 | (let ((b0 (prog1 (char-after) (forward-char))) 295 | (b1 (prog1 (char-after) (forward-char)))) 296 | (cl-case byte-order 297 | (:> (logior (ash b0 8) b1)) 298 | (:< (logior (ash b1 8) b0))))) 299 | 300 | (defun bitpack-load-s16 (byte-order) 301 | "Load signed 16-bit integer from buffer at point per BYTE-ORDER. 302 | 303 | BYTE-ORDER may be :> (big endian) or :< (little endian). The 304 | point will be left just after the loaded value." 305 | (let ((x (bitpack-load-u16 byte-order))) 306 | (if (> x #x7fff) 307 | (logior -65536 x) 308 | x))) 309 | 310 | (defun bitpack-load-u32 (byte-order) 311 | "Load unsigned 32-bit integer from buffer at point per BYTE-ORDER. 312 | 313 | BYTE-ORDER may be :> (big endian) or :< (little endian). The 314 | point will be left just after the loaded value." 315 | (let ((b0 (prog1 (char-after) (forward-char))) 316 | (b1 (prog1 (char-after) (forward-char))) 317 | (b2 (prog1 (char-after) (forward-char))) 318 | (b3 (prog1 (char-after) (forward-char)))) 319 | (cl-case byte-order 320 | (:> (logior (ash b0 24) (ash b1 16) (ash b2 8) b3)) 321 | (:< (logior (ash b3 24) (ash b2 16) (ash b1 8) b0))))) 322 | 323 | (defun bitpack-load-s32 (byte-order) 324 | "Load signed 32-bit integer from buffer at point per BYTE-ORDER. 325 | 326 | BYTE-ORDER may be :> (big endian) or :< (little endian). The 327 | point will be left just after the loaded value." 328 | (let ((x (bitpack-load-u32 byte-order))) 329 | (if (> x #x7fffffff) 330 | (logior -4294967296 x) 331 | x))) 332 | 333 | (defmacro bitpack--strict (&rest body) 334 | "Toss out BODY if bignum is supported." 335 | (declare (indent 0)) 336 | (unless (fboundp 'bignump) 337 | `(progn ,@body))) 338 | 339 | (defun bitpack--load-i64 (byte-order) 340 | "Load 64-bit integer from buffer at point per BYTE-ORDER. 341 | 342 | BYTE-ORDER may be :> (big endian) or :< (little endian). The 343 | point will be left just after the loaded value. 344 | 345 | This is an internal function, use `bitpack-load-u64' or 346 | `bitpack-load-s64' instead." 347 | (let ((b0 (prog1 (char-after) (forward-char))) 348 | (b1 (prog1 (char-after) (forward-char))) 349 | (b2 (prog1 (char-after) (forward-char))) 350 | (b3 (prog1 (char-after) (forward-char))) 351 | (b4 (prog1 (char-after) (forward-char))) 352 | (b5 (prog1 (char-after) (forward-char))) 353 | (b6 (prog1 (char-after) (forward-char))) 354 | (b7 (prog1 (char-after) (forward-char)))) 355 | (bitpack--strict 356 | (let* ((msb (cl-case byte-order 357 | (:> b0) 358 | (:< b7))) 359 | (high (lsh msb -6))) 360 | (unless (or (= high #x00) (= high #x03)) 361 | (signal 'arith-error (list "Unrepresentable" high 362 | b0 b1 b2 b3 b4 b5 b6 b7))))) 363 | (cl-case byte-order 364 | (:> (logior (ash b0 56) (ash b1 48) (ash b2 40) (ash b3 32) 365 | (ash b4 24) (ash b5 16) (ash b6 8) b7)) 366 | (:< (logior (ash b7 56) (ash b6 48) (ash b5 40) (ash b4 32) 367 | (ash b3 24) (ash b2 16) (ash b1 8) b0))))) 368 | 369 | (defun bitpack-load-u64 (byte-order) 370 | "Load unsigned 64-bit integer from buffer at point per BYTE-ORDER. 371 | 372 | BYTE-ORDER may be :> (big endian) or :< (little endian). The 373 | point will be left just after the loaded value. 374 | 375 | Prior to Emacs 27, this function will signal `arith-error' if the 376 | integer cannot be represented as an Emacs Lisp integer." 377 | (let ((x (bitpack--load-i64 byte-order))) 378 | (prog1 x 379 | (bitpack--strict 380 | (when (< x 0) 381 | (signal 'arith-error (cons "Unrepresentable" x))))))) 382 | 383 | (defun bitpack-load-s64 (byte-order) 384 | "Load signed 64-bit integer from buffer at point per BYTE-ORDER. 385 | 386 | BYTE-ORDER may be :> (big endian) or :< (little endian). The 387 | point will be left just after the loaded value. 388 | 389 | Prior to Emacs 27, this function will signal `arith-error' if the 390 | integer cannot be represented as an Emacs Lisp integer." 391 | (let ((x (bitpack--load-i64 byte-order))) 392 | (if (> x #x7fffffffffffffff) 393 | (logior -18446744073709551616 x) 394 | x))) 395 | 396 | (provide 'bitpack) 397 | 398 | ;;; bitpack.el ends here 399 | --------------------------------------------------------------------------------