├── .gitignore
├── .travis.yml
├── LICENSE
├── NEWS
├── README.md
├── doc
├── index.html
├── nibbles-doc.txt
└── style.css
├── float.lisp
├── macro-utils.lisp
├── nibbles.asd
├── package.lisp
├── sbcl-opt
├── fndb.lisp
├── nib-tran.lisp
├── x86-64-vm.lisp
└── x86-vm.lisp
├── streams.lisp
├── tests.lisp
├── types.lisp
└── vectors.lisp
/.gitignore:
--------------------------------------------------------------------------------
1 | *.fasl
2 | *.FASL
3 | *.ufasl
4 | *.ufsl
5 | *.dx32fsl
6 | *.dx64fsl
7 | *.pfsl
8 | *.dfsl
9 | *.p64fsl
10 | *.d64fsl
11 | *.lx32fsl
12 | *.lx64fsl
13 | *.fx32fsl
14 | *.fx64fsl
15 | *.fas
16 | *.lib
17 |
18 |
--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
1 | os: linux
2 | dist: focal
3 | language: generic
4 |
5 | env:
6 | jobs:
7 | - LISP=sbcl
8 | - LISP=ccl
9 | - LISP=clisp
10 | - LISP=ecl
11 | - LISP=abcl
12 | # - LISP=allegro
13 |
14 | matrix:
15 | fast_finish: true
16 | allow_failures:
17 | - env: LISP=allegro
18 | - env: LISP=clisp
19 |
20 | install:
21 | # Install cl-travis
22 | - curl -L https://raw.githubusercontent.com/lispci/cl-travis/master/install.sh | bash
23 |
24 | script:
25 | - cl -e "(print (lisp-implementation-version))(terpri)
26 | (ql:quickload :nibbles/tests :verbose t)
27 | (uiop:quit (if (rt:do-tests) 0 1))"
28 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2010, Nathan Froyd
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are
7 | met:
8 |
9 | * Redistributions of source code must retain the above copyright notice,
10 | this list of conditions and the following disclaimer.
11 |
12 | * Redistributions in binary form must reproduce the above copyright
13 | notice, this list of conditions and the following disclaimer in the
14 | documentation and/or other materials provided with the distribution.
15 |
16 | * Neither the name of the copyright holders nor the names of
17 | contributors to this software may be used to endorse or promote
18 | products derived from this software without specific prior written
19 | permission.
20 |
21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
22 | IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
23 | TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
24 | PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
25 | OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
26 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
27 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 |
--------------------------------------------------------------------------------
/NEWS:
--------------------------------------------------------------------------------
1 | hey emacs, show me an -*- mode: outline -*-
2 |
3 | * Version 0.13, released 2017-03-07
4 |
5 | ** bug fixes
6 |
7 | Fixed problems reading elements into lists.
8 |
9 | Fixed DEFKNOWN issues on newer SBCL versions. (Thanks to Kenan Bölükbaşı.)
10 |
11 | ** new features
12 |
13 | Float accessors are now supported on ABCL. (Thanks to Robert Brown.)
14 |
15 | * Version 0.12, released 2014-10-08
16 |
17 | ** bug fixes
18 |
19 | Better support for Allegro CL modern mode. (Thanks to Markus Flambard.)
20 |
21 | More correct code generation for x86-64 SBCL.
22 |
23 | ** new features
24 |
25 | Float accessors are now MAYBE-INLINE on SBCL. (Thanks to Jan Moringen.)
26 |
27 | * Version 0.11, released 2013-01-14
28 |
29 | ** bug fixes
30 |
31 | IEEE-DOUBLE-REF/* now works correctly on CCL.
32 |
33 | IEEE-SINGLE-REF/* now works correctly on Allegro. (Thanks to Richard
34 | Billington for the bug report.)
35 |
36 | ** new features
37 |
38 | MAKE-OCTET-VECTOR and OCTET-VECTOR convenience functions have been
39 | added, along with the OCTET, OCTET-VECTOR, and SIMPLE-OCTET-VECTOR
40 | types. (Thanks to Jan Moringen.)
41 |
42 | Stream readers and writers for floats have been added, analogous to the
43 | existing functions for integers. These functionsn are only supported on
44 | implementations which support the array accessors (SBCL, CCL, CMUCL for
45 | double-floats; all those including Lispworks and Allegro for
46 | single-floats).
47 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # Introduction #
2 |
3 | When dealing with network protocols and file formats, it's common to
4 | have to read or write 16-, 32-, or 64-bit datatypes in signed or
5 | unsigned flavors. Common Lisp sort of supports this by specifying
6 | `:element-type` for streams, but that facility is underspecified and
7 | there's nothing similar for read/write from octet vectors. What most
8 | people wind up doing is rolling their own small facility for their
9 | particular needs and calling it a day.
10 |
11 | This library attempts to be comprehensive and centralize such
12 | facilities. Functions to read 16-, 32-, and 64-bit quantities from
13 | octet vectors in signed or unsigned flavors are provided; these
14 | functions are also `SETF`able. Since it's sometimes desirable to
15 | read/write directly from streams, functions for doing so are also
16 | provided. Reading/writing IEEE singles/doubles (i.e. `single-float`
17 | and `double-float`) is also supported, with limitations on platforms
18 | that do not fully implement IEEE floating point.
19 |
20 | In addition to centralizing such facilities, NIBBLES also aspires to
21 | become a place where compiler optimizations can be written once and used
22 | everywhere. The intention is that (eventually):
23 |
24 | ``` common-lisp
25 | (nibbles:sb32ref/le vector index)
26 | ```
27 |
28 | will compile (with any necessary safety checks) to a `MOVSX`
29 | instruction on an x86oid processor in SBCL (or other implementations)
30 | if `vector` and `index` are of appropriate types.
31 |
32 | I remember reading a post on comp.lang.lisp that suggested the designers
33 | of Common Lisp ignored the realities of octets and endianness and so
34 | forth. This library is a small step towards remedying that deficiency.
35 |
--------------------------------------------------------------------------------
/doc/index.html:
--------------------------------------------------------------------------------
1 |
3 | nibbles nibbles nibbles is a library for accessing multibyte integers from
4 | octet arrays and streams. While such accessors are straightforward to
5 | write, nibbles aims to centralize such facilities and also
6 | provide optimizations for them when appropriate.
Installation nibbles can be downloaded at http://www.method-combination.net/lisp/files/nibbles.tar.gz . The latest version is 0.11.
It comes with an ASDF system definition, so (ASDF:OOS
7 | 'ASDF:LOAD-OP :NIBBLES) should be all that you need to get started.
License nibbles is released under a MIT-like license; you can do pretty
8 | much anything you want to with the code except claim that you wrote
9 | it.
Integer array accessors ub16ref/le vector index => value ub32ref/le vector index => value ub64ref/le vector index => value This family of functions accesses an unsigned 16-bit, 32-bit or
10 | 64-bit value stored in little-endian order starting at index in vector . vector must be a (VECTOR (UNSIGNED-BYTE 8)) . These functions are SETFable. For instance:
CL-USER> (nibbles:ub16ref/le (coerce #(42 53) '(vector (unsigned-byte 8))) 0)
11 | 13610
12 | CL-USER> (format nil "~X" *)
13 | "352A" ub16ref/be vector index => value ub32ref/be vector index => value ub64ref/be vector index => value As the above, only the value is accessed in big-endian order. For instance:
CL-USER> (nibbles:ub16ref/be (coerce #(42 53) '(vector (unsigned-byte 8))) 0)
14 | 10805
15 | CL-USER> (format nil "~X" *)
16 | "2A35" sb16ref/le vector index => value sb32ref/le vector index => value sb64ref/le vector index => value sb16ref/be vector index => value sb32ref/be vector index => value sb64ref/be vector index => value As the above, only the value accessed is a signed value. For instance:
CL-USER> (nibbles:sb16ref/be (coerce #(81 92) '(vector (unsigned-byte 8))) 0)
17 | 20828
18 | CL-USER> (nibbles:sb16ref/be (coerce #(129 135) '(vector (unsigned-byte 8))) 0)
19 | -32377
20 | CL-USER> (format nil "~X ~X" ** *)
21 | "515C -7E79"
22 | CL-USER> (nibbles:sb16ref/le (coerce #(81 92) '(vector (unsigned-byte 8))) 0)
23 | 23633
24 | CL-USER> (nibbles:sb16ref/le (coerce #(129 135) '(vector (unsigned-byte 8))) 0)
25 | -30847
26 | CL-USER> (format nil "~X ~X" ** *)
27 | "5C51 -787F" Stream readers read-ub16/le stream => value read-ub32/le stream => value read-ub64/le stream => value This family of functions reads an unsigned 16-bit, 32-bit, or
28 | 64-bit value from stream in little-endian order. stream
29 | must have an element-type of (UNSIGNED-BYTE 8) .
read-ub16/be stream => value read-ub32/be stream => value read-ub64/be stream => value As the above, only the value is read in big-endian order.
read-sb16/le stream => value read-sb32/le stream => value read-sb64/le stream => value read-sb16/be stream => value read-sb32/be stream => value read-sb64/be stream => value As the above, only the value is signed, rather than unsigned.
Stream writers write-ub16/le integer stream => value write-ub32/le integer stream => value write-ub64/le integer stream => value This family of functions writes an unsigned 16-bit, 32-bit, or
30 | 64-bit integer to stream in little-endian order. stream
31 | must have an element-type of (UNSIGNED-BYTE 8) . The value written
32 | is returned.
write-ub16/be integer stream => value write-ub32/be integer stream => value write-ub64/be integer stream => value As the above, only the value is read in big-endian order.
write-sb16/le integer stream => value write-sb32/le integer stream => value write-sb64/le integer stream => value write-sb16/be integer stream => value write-sb32/be integer stream => value write-sb64/be integer stream => value As the above, only the value is signed, rather than unsigned.
--------------------------------------------------------------------------------
/doc/nibbles-doc.txt:
--------------------------------------------------------------------------------
1 | (:author "Nathan Froyd"
2 | :email "froydnj@gmail.com"
3 | :package "nibbles"
4 | :cl-package "NIBBLES"
5 | :version #.(asdf:component-version (asdf:find-system :nibbles))
6 | :homepage "http://www.method-combination.net/lisp/nibbles/"
7 | :download "http://www.method-combination.net/lisp/files/nibbles.tar.gz")
8 |
9 | (:h1 ${package})
10 |
11 | (:p ${package} " is a library for accessing multibyte integers from
12 | octet arrays and streams. While such accessors are straightforward to
13 | write, " ${package} " aims to centralize such facilities and also
14 | provide optimizations for them when appropriate.")
15 |
16 | (:h2 "Installation")
17 |
18 | (:p ${package} " can be downloaded at " (:url ${download} ${download})
19 | ". The latest version is " ${version} ".")
20 |
21 | (:p "It comes with an ASDF system definition, so " `(ASDF:OOS
22 | 'ASDF:LOAD-OP :NIBBLES)` " should be all that you need to get started.")
23 |
24 | (:h2 "License")
25 |
26 | (:p ${package} " is released under a MIT-like license; you can do pretty
27 | much anything you want to with the code except claim that you wrote
28 | it.")
29 |
30 | (:h2 "Integer array accessors")
31 |
32 | (:describe :accessor (nibbles:ub16ref/le value)
33 | (nibbles:ub32ref/le value)
34 | (nibbles:ub64ref/le value))
35 |
36 | (:p "This family of functions accesses an unsigned 16-bit, 32-bit or
37 | 64-bit value stored in little-endian order starting at " 'index' " in "
38 | 'vector' ". " 'vector' " must be a " `(VECTOR (UNSIGNED-BYTE 8))`
39 | ". These functions are SETFable. For instance:")
40 |
41 | (:pre "CL-USER> (nibbles:ub16ref/le (coerce #(42 53) '(vector (unsigned-byte 8))) 0)
42 | 13610
43 | CL-USER> (format nil \"~X\" *)
44 | \"352A\"")
45 |
46 | (:describe :accessor (nibbles:ub16ref/be value)
47 | (nibbles:ub32ref/be value)
48 | (nibbles:ub64ref/be value))
49 |
50 | (:p "As the above, only the value is accessed in big-endian order. For instance:")
51 |
52 | (:pre "CL-USER> (nibbles:ub16ref/be (coerce #(42 53) '(vector (unsigned-byte 8))) 0)
53 | 10805
54 | CL-USER> (format nil \"~X\" *)
55 | \"2A35\"")
56 |
57 | (:describe :accessor (nibbles:sb16ref/le value)
58 | (nibbles:sb32ref/le value)
59 | (nibbles:sb64ref/le value))
60 |
61 | (:describe :accessor (nibbles:sb16ref/be value)
62 | (nibbles:sb32ref/be value)
63 | (nibbles:sb64ref/be value))
64 |
65 | (:p "As the above, only the value accessed is a signed value. For instance:")
66 |
67 | (:pre "CL-USER> (nibbles:sb16ref/be (coerce #(81 92) '(vector (unsigned-byte 8))) 0)
68 | 20828
69 | CL-USER> (nibbles:sb16ref/be (coerce #(129 135) '(vector (unsigned-byte 8))) 0)
70 | -32377
71 | CL-USER> (format nil \"~X ~X\" ** *)
72 | \"515C -7E79\"
73 | CL-USER> (nibbles:sb16ref/le (coerce #(81 92) '(vector (unsigned-byte 8))) 0)
74 | 23633
75 | CL-USER> (nibbles:sb16ref/le (coerce #(129 135) '(vector (unsigned-byte 8))) 0)
76 | -30847
77 | CL-USER> (format nil \"~X ~X\" ** *)
78 | \"5C51 -787F\"")
79 |
80 | (:h2 "Stream readers")
81 |
82 | (:describe :function (nibbles:read-ub16/le value)
83 | (nibbles:read-ub32/le value)
84 | (nibbles:read-ub64/le value))
85 |
86 | (:p "This family of functions reads an unsigned 16-bit, 32-bit, or
87 | 64-bit value from " 'stream' " in little-endian order. " 'stream' "
88 | must have an element-type of " `(UNSIGNED-BYTE 8)` ".")
89 |
90 | (:describe :function (nibbles:read-ub16/be value)
91 | (nibbles:read-ub32/be value)
92 | (nibbles:read-ub64/be value))
93 |
94 | (:p "As the above, only the value is read in big-endian order.")
95 |
96 | (:describe :function (nibbles:read-sb16/le value)
97 | (nibbles:read-sb32/le value)
98 | (nibbles:read-sb64/le value))
99 | (:describe :function (nibbles:read-sb16/be value)
100 | (nibbles:read-sb32/be value)
101 | (nibbles:read-sb64/be value))
102 |
103 | (:p "As the above, only the value is signed, rather than unsigned.")
104 |
105 | (:h2 "Stream writers")
106 |
107 | (:describe :function (nibbles:write-ub16/le value)
108 | (nibbles:write-ub32/le value)
109 | (nibbles:write-ub64/le value))
110 |
111 | (:p "This family of functions writes an unsigned 16-bit, 32-bit, or
112 | 64-bit " 'integer' " to " 'stream' " in little-endian order. " 'stream' "
113 | must have an element-type of " `(UNSIGNED-BYTE 8)` ". The value written
114 | is returned.")
115 |
116 | (:describe :function (nibbles:write-ub16/be value)
117 | (nibbles:write-ub32/be value)
118 | (nibbles:write-ub64/be value))
119 |
120 | (:p "As the above, only the value is read in big-endian order.")
121 |
122 | (:describe :function (nibbles:write-sb16/le value)
123 | (nibbles:write-sb32/le value)
124 | (nibbles:write-sb64/le value))
125 | (:describe :function (nibbles:write-sb16/be value)
126 | (nibbles:write-sb32/be value)
127 | (nibbles:write-sb64/be value))
128 |
129 | (:p "As the above, only the value is signed, rather than unsigned.")
130 |
131 |
--------------------------------------------------------------------------------
/doc/style.css:
--------------------------------------------------------------------------------
1 | body {
2 | margin: 1em 5% 1em 5%;
3 | }
4 |
5 | p {
6 | margin-top: 0.5em;
7 | margin-bottom: 0.5em;
8 | }
9 |
10 | pre {
11 | padding: 0;
12 | margin: 0;
13 | }
14 |
15 | h1, h2 {
16 | border-bottom: 2px solid #449977;
17 | }
18 |
19 | h1, h2, h3, h4, h5, h6 {
20 | font-family: sans-serif;
21 | line-height: 1.3;
22 | }
23 |
24 | a:link {
25 | color: #449977;
26 | }
27 |
28 | a:visited {
29 | color: purple;
30 | }
31 |
32 | a {
33 | text-decoration: none;
34 | padding: 1px 2px;
35 | }
36 |
37 | a:hover {
38 | text-decoration: none;
39 | padding: 1px;
40 | border: 1px solid #000000;
41 | }
42 |
43 | .lisp-symbol {
44 | margin-right: 10%;
45 | margin-top: 1.5em;
46 | margin-bottom: 1.5em;
47 | border: 1px solid #449977;
48 | background: #eeeeee;
49 | padding: 0.5em;
50 | }
51 |
52 | .note {
53 | margin-right: 10%;
54 | margin-top: 1.5em;
55 | margin-bottom: 1.5em;
56 | }
57 |
58 | td.content {
59 | padding: 0;
60 | }
61 |
62 | td.title {
63 | font-family: sans-serif;
64 | font-size: 1.1em;
65 | font-weight: bold;
66 | text-align: left;
67 | vertical-align: top;
68 | text-decoration: underline;
69 | padding-right: 0.5em;
70 | margin-top: 0.0em;
71 | margin-bottom: 0.5em;
72 | }
73 |
74 | .note td.content {
75 | padding-left: 0.5em;
76 | border-left: 2px solid #449977;
77 | }
78 |
--------------------------------------------------------------------------------
/float.lisp:
--------------------------------------------------------------------------------
1 | ;;;; float.lisp -- convert between IEEE floating point numbers and bits
2 |
3 | (cl:in-package :nibbles)
4 |
5 | (defun make-single-float (bits)
6 | (let ((exponent-bits (ldb (byte 8 23) bits))
7 | (significand-bits (ldb (byte 23 0) bits)))
8 | (when (= exponent-bits 255)
9 | (error (if (zerop significand-bits)
10 | "floating point infinities are not supported"
11 | "floating point NaNs are not supported")))
12 | #+clisp
13 | (when (and (zerop exponent-bits) (plusp significand-bits))
14 | (error "subnormal floating point numbers are not supported"))
15 | (let ((sign (if (zerop (ldb (byte 1 31) bits)) 1f0 -1f0))
16 | (significand (logior significand-bits (if (zerop exponent-bits) 0 (ash 1 23))))
17 | (exponent (if (zerop exponent-bits) -126 (- exponent-bits 127))))
18 | (* sign (scale-float (float significand 1f0) (- exponent 23))))))
19 |
20 | (defun make-double-float (high low)
21 | (let ((exponent-bits (ldb (byte 11 20) high))
22 | (significand-bits (logior low (ash (ldb (byte 20 0) high) 32))))
23 | (when (= exponent-bits 2047)
24 | (error (if (zerop significand-bits)
25 | "floating point infinities are not supported"
26 | "floating point NaNs are not supported")))
27 | #+clisp
28 | (when (and (zerop exponent-bits) (plusp significand-bits))
29 | (error "subnormal floating point numbers are not supported"))
30 | (let ((sign (if (zerop (ldb (byte 1 31) high)) 1d0 -1d0))
31 | (significand (logior significand-bits (if (zerop exponent-bits) 0 (ash 1 52))))
32 | (exponent (if (zerop exponent-bits) -1022 (- exponent-bits 1023))))
33 | (* sign (scale-float (float significand 1d0) (- exponent 52))))))
34 |
35 | (defun single-float-bits (float)
36 | (multiple-value-bind (significand exponent sign)
37 | (decode-float float)
38 | (let ((sign-bit (if (plusp sign) 0 1))
39 | (exponent-bits (if (zerop significand) 0 (+ exponent 127 -1)))
40 | (significand-bits (floor (* #.(expt 2f0 24) significand))))
41 | (when (<= exponent-bits 0)
42 | (setf significand-bits (ash significand-bits (1- exponent-bits)))
43 | (setf exponent-bits 0))
44 | (logior (ash sign-bit 31) (ash exponent-bits 23) (ldb (byte 23 0) significand-bits)))))
45 |
46 | (defun double-float-bits (float)
47 | (multiple-value-bind (significand exponent sign)
48 | (decode-float float)
49 | (let ((sign-bit (if (plusp sign) 0 1))
50 | (exponent-bits (if (zerop significand) 0 (+ exponent 1023 -1)))
51 | (significand-bits (floor (* #.(expt 2d0 53) significand))))
52 | (when (<= exponent-bits 0)
53 | (setf significand-bits (ash significand-bits (1- exponent-bits)))
54 | (setf exponent-bits 0))
55 | (values
56 | (logior (ash sign-bit 31) (ash exponent-bits 20) (ldb (byte 20 32) significand-bits))
57 | (ldb (byte 32 0) significand-bits)))))
58 |
--------------------------------------------------------------------------------
/macro-utils.lisp:
--------------------------------------------------------------------------------
1 | ;;;; macro-utils.lisp -- functions for compile-time macros
2 |
3 | (cl:in-package :nibbles)
4 |
5 | (defun byte-fun-name (bitsize signedp big-endian-p desc)
6 | (let ((*package* (find-package :nibbles)))
7 | (intern (format nil "~A~D~A/~A"
8 | (symbol-name (if signedp :sb :ub))
9 | bitsize
10 | (symbol-name desc)
11 | (symbol-name (if big-endian-p :be :le))))))
12 |
13 | (defun float-fun-name (float-type big-endian-p desc)
14 | (let ((*package* (find-package :nibbles)))
15 | (intern (format nil "~A-~A-~A/~A"
16 | (symbol-name :ieee)
17 | (symbol-name float-type)
18 | (symbol-name desc)
19 | (symbol-name (if big-endian-p :be :le))))))
20 |
21 | (defun byte-ref-fun-name (bitsize signedp big-endian-p)
22 | (byte-fun-name bitsize signedp big-endian-p :ref))
23 |
24 | (defun float-ref-fun-name (float-type big-endian-p)
25 | (float-fun-name float-type big-endian-p :ref))
26 |
27 | (defun byte-set-fun-name (bitsize signedp big-endian-p)
28 | (byte-fun-name bitsize signedp big-endian-p :set))
29 |
30 | (defun float-set-fun-name (float-type big-endian-p)
31 | (float-fun-name float-type big-endian-p :set))
32 |
33 | (defun stream-ref-fun-name (bitsize readp signedp big-endian-p)
34 | (let ((*package* (find-package :nibbles)))
35 | (intern (format nil "~A-~A~D/~A"
36 | (symbol-name (if readp :read :write))
37 | (symbol-name (if signedp :sb :ub))
38 | bitsize
39 | (symbol-name (if big-endian-p :be :le))))))
40 |
41 | (defun stream-float-ref-fun-name (float-type readp big-endian-p)
42 | (let ((*package* (find-package :nibbles)))
43 | (intern (format nil "~A-~A-~A/~A"
44 | (symbol-name (if readp :read :write))
45 | (symbol-name :ieee)
46 | (symbol-name float-type)
47 | (symbol-name (if big-endian-p :be :le))))))
48 |
49 | (defun stream-seq-fun-name (bitsize readp signedp big-endian-p)
50 | (let ((*package* (find-package :nibbles)))
51 | (intern (format nil "~A-~A~D/~A-~A"
52 | (symbol-name (if readp :read :write))
53 | (symbol-name (if signedp :sb :ub))
54 | bitsize
55 | (symbol-name (if big-endian-p :be :le))
56 | (symbol-name :sequence)))))
57 |
58 | (defun stream-float-seq-fun-name (float-type readp big-endian-p)
59 | (let ((*package* (find-package :nibbles)))
60 | (intern (format nil "~A-~A-~A/~A-~A"
61 | (symbol-name (if readp :read :write))
62 | (symbol-name :ieee)
63 | (symbol-name float-type)
64 | (symbol-name (if big-endian-p :be :le))
65 | (symbol-name :sequence)))))
66 |
67 | (defun stream-into-seq-fun-name (bitsize signedp big-endian-p)
68 | (let ((*package* (find-package :nibbles)))
69 | (intern (format nil "~A-~A~D/~A-~A"
70 | (symbol-name :read)
71 | (symbol-name (if signedp :sb :ub))
72 | bitsize
73 | (symbol-name (if big-endian-p :be :le))
74 | (symbol-name :into-sequence)))))
75 |
76 | (defun stream-float-into-seq-fun-name (float-type big-endian-p)
77 | (let ((*package* (find-package :nibbles)))
78 | (intern (format nil "~A-~A/~A-~A"
79 | (symbol-name :read-ieee)
80 | (symbol-name float-type)
81 | (symbol-name (if big-endian-p :be :le))
82 | (symbol-name :into-sequence)))))
83 |
84 | (defun internalify (s)
85 | (let ((*package* (find-package :nibbles)))
86 | (intern (concatenate 'string "%" (string s)))))
87 |
88 | (defun format-docstring (&rest args)
89 | (loop with docstring = (apply #'format nil args)
90 | for start = 0 then (when pos (1+ pos))
91 | for pos = (and start (position #\Space docstring :start start))
92 | while start
93 | collect (subseq docstring start pos) into words
94 | finally (return (format nil "~{~<~%~1,76:;~A~>~^ ~}"
95 | words))))
96 |
97 | (defun ref-form (vector-name index-name byte-size signedp big-endian-p)
98 | "Return a form that fetches a SIGNEDP BYTE-SIZE value from VECTOR-NAME,
99 | starting at INDEX-NAME. The value is stored in the vector according to
100 | BIG-ENDIAN-P."
101 | (multiple-value-bind (low high increment compare)
102 | (if big-endian-p
103 | (values 0 (1- byte-size) 1 #'>)
104 | (values (1- byte-size) 0 -1 #'<))
105 | (do ((i (+ low increment) (+ i increment))
106 | (shift (* (- byte-size 2) 8) (- shift 8))
107 | (forms nil))
108 | ((funcall compare i high)
109 | `(let* ((high-byte (aref , vector-name
110 | (+ ,index-name ,low)))
111 | ;; Would be great if we could just sign-extend along
112 | ;; with the load, but this is as good as it gets in
113 | ;; portable Common Lisp.
114 | (signed-high ,(if signedp
115 | `(if (logbitp 7 high-byte)
116 | (- high-byte 256)
117 | high-byte)
118 | 'high-byte))
119 | (shifted-into-place
120 | (ash signed-high ,(* (1- byte-size) 8))))
121 | (declare (type (unsigned-byte 8) high-byte))
122 | (declare (type (,(if signedp 'signed-byte 'unsigned-byte) 8)
123 | signed-high))
124 | (logior shifted-into-place ,@(nreverse forms))))
125 | (push `(ash (aref ,vector-name
126 | (+ ,index-name ,i))
127 | ,shift)
128 | forms))))
129 | (defun set-form (vector-name index-name value-name byte-size big-endian-p)
130 | "Return a form that stores a BYTE-SIZE VALUE-NAME into VECTOR-NAME,
131 | starting at INDEX-NAME. The value is stored in the vector according to
132 | BIG-ENDIAN-P. The form returns VALUE-NAME."
133 | `(progn
134 | ,@(loop for i from 1 to byte-size
135 | collect (let ((offset (if big-endian-p
136 | (- byte-size i)
137 | (1- i))))
138 | `(setf (aref ,vector-name
139 | (+ ,index-name ,offset))
140 | (ldb (byte 8 ,(* 8 (1- i))) ,value-name))))
141 | ,value-name))
142 |
--------------------------------------------------------------------------------
/nibbles.asd:
--------------------------------------------------------------------------------
1 | ; -*- mode: lisp -*-
2 |
3 | (cl:defpackage :nibbles-system
4 | (:use :cl))
5 |
6 | (cl:in-package :nibbles-system)
7 |
8 | (defclass nibbles-source-file (asdf:cl-source-file) ())
9 | (defclass txt-file (asdf:doc-file) ((type :initform "txt")))
10 | (defclass css-file (asdf:doc-file) ((type :initform "css")))
11 |
12 | (defmethod asdf:perform :around ((op asdf:compile-op) (c nibbles-source-file))
13 | (let ((*print-base* 10) ; INTERN'ing FORMAT'd symbols
14 | (*print-case* :upcase)
15 | #+sbcl (sb-ext:*inline-expansion-limit* (max sb-ext:*inline-expansion-limit* 1000))
16 | #+cmu (ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000)))
17 | (call-next-method)))
18 |
19 | (defmethod asdf:perform :around ((op asdf:load-op) (c nibbles-source-file))
20 | (call-next-method))
21 |
22 | (asdf:defsystem "nibbles"
23 | :version "0.17"
24 | :author "Nathan Froyd "
25 | :maintainer "Sharp Lispers "
26 | :description "A library for accessing octet-addressed blocks of data in big- and little-endian orders"
27 | :license "BSD-style (http://opensource.org/licenses/BSD-3-Clause)"
28 | :default-component-class nibbles-source-file
29 | :components ((:static-file "README.md")
30 | (:static-file "LICENSE")
31 | (:static-file "NEWS")
32 | (:file "package")
33 | ;; TODO: Add ecl when ECL version 23.9.9 or later is generally available.
34 | ;; If you change this expression, change the one in the test system definition.
35 | #-(or abcl allegro ccl clasp clisp cmu lispworks mezzano sbcl)
36 | (:file "float" :depends-on ("package"))
37 | (:file "types" :depends-on ("package"))
38 | (:file "macro-utils" :depends-on ("package"))
39 | (:file "vectors" :depends-on ("types" "macro-utils"))
40 | (:file "streams" :depends-on ("vectors"))
41 | (:module "doc"
42 | :components ((:html-file "index")
43 | (:txt-file "nibbles-doc")
44 | (:css-file "style")))
45 | (:module "sbcl-opt"
46 | :if-feature :sbcl
47 | :depends-on ("package" "macro-utils")
48 | :components ((:file "fndb")
49 | (:file "nib-tran" :depends-on ("fndb"))
50 | (:file "x86-vm" :if-feature :x86 :depends-on ("fndb"))
51 | (:file "x86-64-vm" :if-feature :x86-64 :depends-on ("fndb")))))
52 | :in-order-to ((asdf:test-op (asdf:test-op "nibbles/tests")))
53 | :perform (asdf:prepare-op (component operation)
54 | ;; nibbles uses SBCL's assembler on x86 and x86-64. The
55 | ;; interface of the assembler with SBCL version 1.4.10.
56 | #+(and sbcl (or x86 x86-64)) (sb-ext:assert-version->= 1 4 10)))
57 |
58 | (asdf:defsystem "nibbles/tests"
59 | :depends-on ("nibbles" "rt")
60 | :version "0.2"
61 | :author "Nathan Froyd "
62 | :maintainer "Sharp Lispers "
63 | :components (;; If you change this expression, change the one in the nibbles system definition.
64 | #+(or abcl allegro ccl clasp clisp cmu lispworks mezzano sbcl)
65 | (:file "float")
66 | (:file "tests"))
67 | :perform (asdf:test-op (operation component)
68 | (or (uiop:symbol-call '#:rtest '#:do-tests)
69 | (error "TEST-OP failed for NIBBLES-TESTS"))))
70 |
--------------------------------------------------------------------------------
/package.lisp:
--------------------------------------------------------------------------------
1 | (cl:defpackage :nibbles
2 | (:use :cl)
3 | ;; Basic types and constructors.
4 | (:export #:octet #:index
5 | #:octet-vector #:simple-octet-vector
6 | #:make-octet-vector)
7 | ;; Basic octet vector accessors.
8 | (:export #:ub16ref/le #:ub16ref/be #:sb16ref/le #:sb16ref/be
9 | #:ub24ref/le #:ub24ref/be #:sb24ref/le #:sb24ref/be
10 | #:ub32ref/le #:ub32ref/be #:sb32ref/le #:sb32ref/be
11 | #:ub64ref/le #:ub64ref/be #:sb64ref/le #:sb64ref/be)
12 | ;; Stream readers.
13 | (:export #:read-ub16/le #:read-ub16/be #:read-sb16/be #:read-sb16/le
14 | #:read-ub24/le #:read-ub24/be #:read-sb24/be #:read-sb24/le
15 | #:read-ub32/le #:read-ub32/be #:read-sb32/be #:read-sb32/le
16 | #:read-ub64/le #:read-ub64/be #:read-sb64/be #:read-sb64/le)
17 | ;; Stream readers for vectors.
18 | (:export #:read-ub16/le-sequence #:read-ub16/be-sequence
19 | #:read-sb16/le-sequence #:read-sb16/be-sequence
20 | #:read-ub24/le-sequence #:read-ub24/be-sequence
21 | #:read-sb24/le-sequence #:read-sb24/be-sequence
22 | #:read-ub32/le-sequence #:read-ub32/be-sequence
23 | #:read-sb32/le-sequence #:read-sb32/be-sequence
24 | #:read-ub64/le-sequence #:read-ub64/be-sequence
25 | #:read-sb64/le-sequence #:read-sb64/be-sequence)
26 | ;; Non-consing variants akin to READ-SEQUENCE.
27 | (:export #:read-ub16/le-into-sequence #:read-ub16/be-into-sequence
28 | #:read-sb16/le-into-sequence #:read-sb16/be-into-sequence
29 | #:read-ub24/le-into-sequence #:read-ub24/be-into-sequence
30 | #:read-sb24/le-into-sequence #:read-sb24/be-into-sequence
31 | #:read-ub32/le-into-sequence #:read-ub32/be-into-sequence
32 | #:read-sb32/le-into-sequence #:read-sb32/be-into-sequence
33 | #:read-ub64/le-into-sequence #:read-ub64/be-into-sequence
34 | #:read-sb64/le-into-sequence #:read-sb64/be-into-sequence)
35 | ;; Stream writers.
36 | (:export #:write-ub16/le #:write-ub16/be #:write-sb16/be #:write-sb16/le
37 | #:write-ub24/le #:write-ub24/be #:write-sb24/be #:write-sb24/le
38 | #:write-ub32/le #:write-ub32/be #:write-sb32/be #:write-sb32/le
39 | #:write-ub64/le #:write-ub64/be #:write-sb64/be #:write-sb64/le)
40 | ;; Stream writers for vectors.
41 | (:export #:write-ub16/le-sequence #:write-ub16/be-sequence
42 | #:write-sb16/le-sequence #:write-sb16/be-sequence
43 | #:write-ub24/le-sequence #:write-ub24/be-sequence
44 | #:write-sb24/le-sequence #:write-sb24/be-sequence
45 | #:write-ub32/le-sequence #:write-ub32/be-sequence
46 | #:write-sb32/le-sequence #:write-sb32/be-sequence
47 | #:write-ub64/le-sequence #:write-ub64/be-sequence
48 | #:write-sb64/le-sequence #:write-sb64/be-sequence)
49 |
50 | ;; The following floating-point functions are not fully supported on all platforms.
51 |
52 | ;; Floating-point octet vector accessors.
53 | (:export #:ieee-single-ref/be #:ieee-single-ref/le
54 | #:ieee-double-ref/be #:ieee-double-ref/le)
55 | ;; Floating-point stream readers.
56 | (:export #:read-ieee-single/be #:read-ieee-single/le
57 | #:read-ieee-double/be #:read-ieee-double/le)
58 | ;; Stream readers for floating-point sequences.
59 | (:export #:read-ieee-single/be-sequence #:read-ieee-single/le-sequence
60 | #:read-ieee-double/be-sequence #:read-ieee-double/le-sequence)
61 | ;; Non-consing variants akin to READ-SEQUENCE.
62 | (:export #:read-ieee-single/be-into-sequence #:read-ieee-single/le-into-sequence
63 | #:read-ieee-double/be-into-sequence #:read-ieee-double/le-into-sequence)
64 | ;; Stream writers.
65 | (:export #:write-ieee-single/be #:write-ieee-single/le
66 | #:write-ieee-double/be #:write-ieee-double/le)
67 | ;; Stream writers for sequences.
68 | (:export #:write-ieee-single/be-sequence #:write-ieee-single/le-sequence
69 | #:write-ieee-double/be-sequence #:write-ieee-double/le-sequence))
70 |
--------------------------------------------------------------------------------
/sbcl-opt/fndb.lisp:
--------------------------------------------------------------------------------
1 | ;;;; fndb.lisp -- DEFKNOWNish bits for SBCL
2 |
3 | (cl:in-package :nibbles)
4 |
5 | ;;; Efficient array bounds checking
6 | (sb-c:defknown %check-bound
7 | ((simple-array (unsigned-byte 8) (*)) index (and fixnum sb-vm:word)
8 | (member 2 4 3 8 16))
9 | index (sb-c:any) :overwrite-fndb-silently t)
10 |
11 | ;; We DEFKNOWN the exported functions so we can DEFTRANSFORM them.
12 | ;; We DEFKNOWN the %-functions so we can DEFINE-VOP them.
13 |
14 | #.(loop for i from 0 to #-x86-64 #b1011 #+x86-64 #b1111
15 | for bitsize = (ecase (ldb (byte 2 2) i)
16 | (0 16)
17 | (1 24)
18 | (2 32)
19 | (3 64))
20 | for signedp = (logbitp 1 i)
21 | for setterp = (logbitp 0 i)
22 | for byte-fun = (if setterp
23 | #'byte-set-fun-name
24 | #'byte-ref-fun-name)
25 | for big-fun = (funcall byte-fun bitsize signedp t)
26 | for little-fun = (funcall byte-fun bitsize signedp nil)
27 | for internal-big = (internalify big-fun)
28 | for internal-little = (internalify little-fun)
29 | for arg-type = `(,(if signedp
30 | 'signed-byte
31 | 'unsigned-byte)
32 | ,bitsize)
33 | for external-arg-types = `(array index ,@(when setterp
34 | `(,arg-type)))
35 | for internal-arg-types = (subst '(simple-array (unsigned-byte 8)) 'array
36 | external-arg-types)
37 | collect `(sb-c:defknown (,big-fun ,little-fun) ,external-arg-types
38 | ,arg-type (sb-c:any) :overwrite-fndb-silently t) into defknowns
39 | collect `(sb-c:defknown (,internal-big ,internal-little)
40 | ,internal-arg-types
41 | ,arg-type (sb-c:any) :overwrite-fndb-silently t) into defknowns
42 | finally (return `(progn ,@defknowns)))
43 |
--------------------------------------------------------------------------------
/sbcl-opt/nib-tran.lisp:
--------------------------------------------------------------------------------
1 | ;;;; nib-tran.lisp -- DEFTRANSFORMs for SBCL
2 |
3 | (cl:in-package :nibbles)
4 |
5 | (sb-c:deftransform %check-bound ((vector bound offset n-bytes)
6 | ((simple-array (unsigned-byte 8) (*)) index
7 | (and fixnum sb-vm:word)
8 | (member 2 3 4 8 16))
9 | * :node node)
10 | "optimize away bounds check"
11 | ;; cf. sb-c::%check-bound transform
12 | (cond ((sb-c:policy node (= sb-c::insert-array-bounds-checks 0))
13 | 'offset)
14 | ((not (sb-c::constant-lvar-p bound))
15 | (sb-c::give-up-ir1-transform))
16 | (t
17 | (let* ((dim (sb-c::lvar-value bound))
18 | (n-bytes (sb-c::lvar-value n-bytes))
19 | (upper-bound `(integer 0 (,(- dim n-bytes -1)))))
20 | (if (> n-bytes dim)
21 | (sb-c::give-up-ir1-transform)
22 | `(the ,upper-bound offset))))))
23 |
24 | #.(flet ((specialized-includep (bitsize signedp setterp)
25 | (declare (ignorable bitsize signedp setterp))
26 | ;; Bleh. No good way to solve this atm.
27 | ;;
28 | ;; Non-x86. No support.
29 | #-(or x86 x86-64)
30 | nil
31 | ;; x86 and x86-64. Can do everything.
32 | #+(or x86 x86-64)
33 | t)
34 | (generic-transform-form (fun-name arglist n-bytes
35 | setterp signedp big-endian-p)
36 | (let ((offset-type `(integer 0 ,(- array-dimension-limit n-bytes))))
37 | `(sb-c:deftransform ,fun-name ,arglist
38 | `(locally (declare (type ,',offset-type offset))
39 | ,',(if setterp
40 | (set-form 'vector 'offset 'value n-bytes big-endian-p)
41 | (ref-form 'vector 'offset n-bytes signedp big-endian-p)))))))
42 | (loop for i from 0 to #-x86-64 #b1011 #+x86-64 #b1111
43 | for bitsize = (ecase (ldb (byte 2 2) i)
44 | (0 16)
45 | (1 24)
46 | (2 32)
47 | (3 64))
48 | for signedp = (logbitp 1 i)
49 | for setterp = (logbitp 0 i)
50 | for byte-fun = (if setterp
51 | #'byte-set-fun-name
52 | #'byte-ref-fun-name)
53 | for big-fun = (funcall byte-fun bitsize signedp t)
54 | for little-fun = (funcall byte-fun bitsize signedp nil)
55 | for internal-big = (internalify big-fun)
56 | for internal-little = (internalify little-fun)
57 | for n-bytes = (truncate bitsize 8)
58 | for arg-type = `(,(if signedp
59 | 'signed-byte
60 | 'unsigned-byte)
61 | ,bitsize)
62 | for arglist = `(vector offset ,@(when setterp '(value)))
63 | for external-arg-types = `(array index ,@(when setterp
64 | `(,arg-type)))
65 | for internal-arg-types = (subst '(simple-array (unsigned-byte 8)) 'array
66 | external-arg-types)
67 | for transform-arglist = `(,arglist ,internal-arg-types ,arg-type)
68 | for specialized-big-transform
69 | = `(sb-c:deftransform ,big-fun ,transform-arglist
70 | '(,internal-big vector (%check-bound vector (length vector) offset ,n-bytes)
71 | ,@(when setterp '(value))))
72 | for specialized-little-transform
73 | = (subst internal-little internal-big
74 | (subst little-fun big-fun
75 | specialized-big-transform))
76 | ;; Also include inlining versions for when the argument type
77 | ;; is known to be a simple octet vector and we don't have a
78 | ;; native assembly implementation.
79 | for generic-big-transform
80 | = (generic-transform-form big-fun transform-arglist n-bytes
81 | setterp signedp t)
82 | for generic-little-transform
83 | = (generic-transform-form little-fun transform-arglist n-bytes
84 | setterp signedp nil)
85 | if (specialized-includep bitsize signedp setterp)
86 | collect specialized-big-transform into transforms
87 | else if (<= bitsize sb-vm:n-word-bits)
88 | collect generic-big-transform into transforms
89 | if (specialized-includep bitsize signedp setterp)
90 | collect specialized-little-transform into transforms
91 | else if (<= bitsize sb-vm:n-word-bits)
92 | collect generic-little-transform into transforms
93 | finally (return `(progn ,@transforms))))
94 |
--------------------------------------------------------------------------------
/sbcl-opt/x86-64-vm.lisp:
--------------------------------------------------------------------------------
1 | ;;;; x86-64-vm.lisp -- VOP definitions SBCL
2 |
3 | (cl:in-package :sb-vm)
4 |
5 | (define-vop (%check-bound)
6 | (:translate nibbles::%check-bound)
7 | (:policy :fast-safe)
8 | (:args (array :scs (descriptor-reg))
9 | (bound :scs (any-reg))
10 | (index :scs (any-reg)))
11 | (:arg-types simple-array-unsigned-byte-8 positive-fixnum tagged-num
12 | (:constant (member 2 3 4 8 16)))
13 | (:info offset)
14 | (:temporary (:sc any-reg) temp)
15 | (:results (result :scs (any-reg)))
16 | (:result-types positive-fixnum)
17 | (:vop-var vop)
18 | (:generator 5
19 | (let ((error (generate-error-code vop 'invalid-array-index-error
20 | array bound index)))
21 | ;; We want to check the conditions:
22 | ;;
23 | ;; 0 <= INDEX
24 | ;; INDEX < BOUND
25 | ;; 0 <= INDEX + OFFSET
26 | ;; (INDEX + OFFSET) < BOUND
27 | ;;
28 | ;; We can do this naively with two unsigned checks:
29 | ;;
30 | ;; INDEX <_u BOUND
31 | ;; INDEX + OFFSET <_u BOUND
32 | ;;
33 | ;; If INDEX + OFFSET <_u BOUND, though, INDEX must be less than
34 | ;; BOUND. We *do* need to check for 0 <= INDEX, but that has
35 | ;; already been assured by higher-level machinery.
36 | (inst lea temp (ea (fixnumize offset) nil index))
37 | (inst cmp temp bound)
38 | (inst jmp :a error)
39 | (move result index))))
40 |
41 | #.(flet ((frob (bitsize setterp signedp big-endian-p)
42 | (let* ((name (funcall (if setterp
43 | #'nibbles::byte-set-fun-name
44 | #'nibbles::byte-ref-fun-name)
45 | bitsize signedp big-endian-p))
46 | (internal-name (nibbles::internalify name))
47 | (operand-size (ecase bitsize
48 | (16 :word)
49 | (32 :dword)
50 | (64 :qword)))
51 | (ref-mov-insn (ecase bitsize
52 | (16
53 | (if big-endian-p
54 | 'movzx
55 | (if signedp 'movsx 'movzx)))
56 | (32
57 | (if big-endian-p
58 | 'mov
59 | (if signedp 'movsxd 'movzxd)))
60 | (64 'mov)))
61 | (result-sc (if signedp 'signed-reg 'unsigned-reg))
62 | (result-type (if signedp 'signed-num 'unsigned-num)))
63 | (flet ((movx (insn dest source source-size)
64 | (cond ((eq insn 'mov)
65 | `(inst ,insn ,dest ,source))
66 | ;; (movzx (:dword :qword) dest source) is
67 | ;; no longer allowed on SBCL > 2.1.4.134
68 | ;; but older versions already supported
69 | ;; this new spelling.
70 | ((and (member insn '(movzx movzxd))
71 | (eq source-size :dword))
72 | `(inst mov :dword ,dest ,source))
73 | (t
74 | `(inst ,(case insn (movsxd 'movsx) (movzxd 'movzx) (t insn))
75 | '(,source-size :qword) ,dest ,source))))
76 | (swap-tn-inst-form (tn-name)
77 | (if (= bitsize 16)
78 | `(inst rol ,operand-size ,tn-name 8)
79 | ;; The '(bswap :dword r)' notation is only
80 | ;; supported on SBCL > 1.5.9.
81 | (if (ignore-errors (sb-ext:assert-version->= 1 5 9 17) t)
82 | `(inst bswap ,operand-size ,tn-name)
83 | `(inst bswap (sb-vm::reg-in-size ,tn-name ,operand-size))))))
84 | `(define-vop (,name)
85 | (:translate ,internal-name)
86 | (:policy :fast-safe)
87 | (:args (vector :scs (descriptor-reg))
88 | (index :scs (immediate unsigned-reg))
89 | ,@(when setterp
90 | `((value* :scs (,result-sc) :target result))))
91 | (:arg-types simple-array-unsigned-byte-8
92 | positive-fixnum
93 | ,@(when setterp
94 | `(,result-type)))
95 | ,@(when (and setterp big-endian-p)
96 | `((:temporary (:sc unsigned-reg
97 | :from (:load 0)
98 | :to (:result 0)) temp)))
99 | (:results (result :scs (,result-sc)))
100 | (:result-types ,result-type)
101 | (:generator 3
102 | (let* ((base-disp (- (* vector-data-offset n-word-bytes)
103 | other-pointer-lowtag))
104 | (memref (sc-case index
105 | (immediate
106 | (ea (+ (tn-value index) base-disp) vector))
107 | (t
108 | (ea base-disp vector index)))))
109 | ,@(when (and setterp big-endian-p)
110 | `((inst mov temp value*)
111 | ,(swap-tn-inst-form 'temp)))
112 | ,(if setterp
113 | `(inst mov ,operand-size memref ,(if big-endian-p
114 | 'temp
115 | 'value*))
116 | (movx ref-mov-insn 'result 'memref operand-size))
117 | ,@(if setterp
118 | '((move result value*))
119 | (when big-endian-p
120 | `(,(swap-tn-inst-form 'result)
121 | ,(when (and (/= bitsize 64) signedp)
122 | (movx 'movsx 'result 'result operand-size))))))))))))
123 | (loop for i from 0 upto #b10111
124 | for bitsize = (ecase (ldb (byte 2 3) i)
125 | (0 16)
126 | (1 32)
127 | (2 64))
128 | for setterp = (logbitp 2 i)
129 | for signedp = (logbitp 1 i)
130 | for big-endian-p = (logbitp 0 i)
131 | collect (frob bitsize setterp signedp big-endian-p) into forms
132 | finally (return `(progn ,@forms))))
133 |
134 | ;;; 24-bit accessors need to be handled specially.
135 | #.(flet ((frob (setterp signedp big-endian-p)
136 | (let* ((name (funcall (if setterp
137 | #'nibbles::byte-set-fun-name
138 | #'nibbles::byte-ref-fun-name)
139 | 24 signedp big-endian-p))
140 | (internal-name (nibbles::internalify name))
141 | (result-sc (if signedp 'signed-reg 'unsigned-reg))
142 | (result-type (if signedp 'signed-num 'unsigned-num))
143 | (mov-insn (if signedp 'movsx 'movzx)))
144 | `(define-vop (,name)
145 | (:translate ,internal-name)
146 | (:policy :fast-safe)
147 | (:args (vector :scs (descriptor-reg))
148 | (index :scs (immediate unsigned-reg))
149 | ,@(when setterp `((value :scs (,result-sc) :target result))))
150 | (:arg-types simple-array-unsigned-byte-8 positive-fixnum
151 | ,@(when setterp `(,result-type)))
152 | ,@(when setterp
153 | `((:temporary (:sc unsigned-reg
154 | :from (:load 0)
155 | :to (:result 0)) temp)))
156 | (:results (result :scs (,result-sc) :from (:load 0)))
157 | (:result-types ,result-type)
158 | (:generator 3
159 | (let* ((base-disp (- (* vector-data-offset n-word-bytes)
160 | other-pointer-lowtag))
161 | (low-memref
162 | (sc-case index
163 | (immediate
164 | (ea (+ (tn-value index) base-disp) vector))
165 | (t
166 | (ea base-disp vector index))))
167 | (high-memref
168 | (sc-case index
169 | (immediate
170 | (ea (+ (tn-value index) base-disp 2) vector))
171 | (t
172 | (ea (+ base-disp 2) vector index)))))
173 | ,@(cond
174 | ((and (not setterp) (not big-endian-p))
175 | `((inst ,mov-insn '(:byte :qword) result high-memref)
176 | (inst shl result 16)
177 | (inst mov :word result low-memref)))
178 | ((and (not setterp) big-endian-p)
179 | `((inst mov result low-memref)
180 | (inst rol :word result 8)
181 | (inst ,mov-insn '(:word :qword) result result)
182 | (inst shl result 8)
183 | (inst mov :byte result high-memref)))
184 | ((and setterp (not big-endian-p))
185 | '((inst mov temp value)
186 | (inst mov :word low-memref value)
187 | (inst shr temp 16)
188 | (inst mov :byte high-memref temp)
189 | (move result value)))
190 | ((and setterp big-endian-p)
191 | '((inst mov temp value)
192 | ;; TEMP has the bytes 0 High Mid Low
193 | (inst bswap :dword temp)
194 | ;; L M H 0
195 | (inst shr temp 8)
196 | ;; 0 L M H
197 | (inst mov :word low-memref temp)
198 | (inst shr temp 16)
199 | ;; 0 0 0 L
200 | (inst mov :byte high-memref temp)
201 | (move result value))))))))))
202 | (loop for i from 0 upto #b111
203 | for setterp = (logbitp 2 i)
204 | for signedp = (logbitp 1 i)
205 | for big-endian-p = (logbitp 0 i)
206 | collect (frob setterp signedp big-endian-p) into forms
207 | finally (return `(progn ,@forms))))
208 |
--------------------------------------------------------------------------------
/sbcl-opt/x86-vm.lisp:
--------------------------------------------------------------------------------
1 | ;;;; x86-vm.lisp -- VOP definitions for SBCL
2 |
3 | (cl:in-package :sb-vm)
4 |
5 | (define-vop (%check-bound)
6 | (:translate nibbles::%check-bound)
7 | (:policy :fast-safe)
8 | (:args (array :scs (descriptor-reg))
9 | (bound :scs (any-reg))
10 | (index :scs (any-reg)))
11 | (:arg-types simple-array-unsigned-byte-8 positive-fixnum tagged-num
12 | (:constant (member 2 4 8 16)))
13 | (:info offset)
14 | (:temporary (:sc any-reg) temp)
15 | (:results (result :scs (any-reg)))
16 | (:result-types positive-fixnum)
17 | (:vop-var vop)
18 | (:generator 5
19 | (let ((error (generate-error-code vop 'invalid-array-index-error
20 | array bound index)))
21 | ;; We want to check the conditions:
22 | ;;
23 | ;; 0 <= INDEX
24 | ;; INDEX < BOUND
25 | ;; 0 <= INDEX + OFFSET
26 | ;; (INDEX + OFFSET) < BOUND
27 | ;;
28 | ;; We can do this naively with two unsigned checks:
29 | ;;
30 | ;; INDEX <_u BOUND
31 | ;; INDEX + OFFSET <_u BOUND
32 | ;;
33 | ;; If INDEX + OFFSET <_u BOUND, though, INDEX must be less than
34 | ;; BOUND. We *do* need to check for 0 <= INDEX, but that has
35 | ;; already been assured by higher-level machinery.
36 | (inst lea temp (make-ea :dword :index index :disp (fixnumize offset)))
37 | (inst cmp temp bound)
38 | (inst jmp :a error)
39 | (move result index))))
40 |
41 | #.(flet ((frob (setterp signedp big-endian-p)
42 | (let* ((name (funcall (if setterp
43 | #'nibbles::byte-set-fun-name
44 | #'nibbles::byte-ref-fun-name)
45 | 16 signedp big-endian-p))
46 | (internal-name (nibbles::internalify name))
47 | (result-sc (if signedp 'signed-reg 'unsigned-reg))
48 | (result-type (if signedp 'signed-num 'unsigned-num)))
49 | `(define-vop (,name)
50 | (:translate ,internal-name)
51 | (:policy :fast-safe)
52 | (:args (vector :scs (descriptor-reg))
53 | (index :scs (immediate unsigned-reg))
54 | ,@(when setterp
55 | `((value :scs (,result-sc) :target result))))
56 | (:arg-types simple-array-unsigned-byte-8
57 | positive-fixnum
58 | ,@(when setterp
59 | `(,result-type)))
60 | ,@(when (or setterp big-endian-p)
61 | `((:temporary (:sc unsigned-reg :offset eax-offset
62 | :from ,(if setterp
63 | '(:load 0)
64 | '(:argument 2))
65 | :to (:result 0)) eax)))
66 | (:results (result :scs (,result-sc)))
67 | (:result-types ,result-type)
68 | (:generator 3
69 | (let* ((base-disp (- (* vector-data-offset n-word-bytes)
70 | other-pointer-lowtag))
71 | (memref (sc-case index
72 | (immediate
73 | (make-ea :word :base vector
74 | :disp (+ (tn-value index) base-disp)))
75 | (t
76 | (make-ea :word :base vector
77 | :index index
78 | :disp base-disp)))))
79 | ,(when setterp
80 | '(move eax value))
81 | ,(when (and setterp big-endian-p)
82 | '(inst rol ax-tn 8))
83 | ,(if setterp
84 | '(inst mov memref ax-tn)
85 | `(inst ,(if big-endian-p
86 | 'mov
87 | (if signedp
88 | 'movsx
89 | 'movzx))
90 | ,(if big-endian-p
91 | 'ax-tn
92 | 'result)
93 | memref))
94 | ,@(if setterp
95 | '((move result value))
96 | (when big-endian-p
97 | `(eax ; hack so that it looks used
98 | (inst rol ax-tn 8)
99 | (inst ,(if signedp 'movsx 'movzx)
100 | result ax-tn))))))))))
101 | (loop for i from 0 upto #b111
102 | for setterp = (logbitp 2 i)
103 | for signedp = (logbitp 1 i)
104 | for big-endian-p = (logbitp 0 i)
105 | collect (frob setterp signedp big-endian-p) into forms
106 | finally (return `(progn ,@forms))))
107 |
108 | #.(flet ((frob (setterp signedp big-endian-p)
109 | (let* ((name (funcall (if setterp
110 | #'nibbles::byte-set-fun-name
111 | #'nibbles::byte-ref-fun-name)
112 | 32 signedp big-endian-p))
113 | (internal-name (nibbles::internalify name))
114 | (result-sc (if signedp 'signed-reg 'unsigned-reg))
115 | (result-type (if signedp 'signed-num 'unsigned-num)))
116 | `(define-vop (,name)
117 | (:translate ,internal-name)
118 | (:policy :fast-safe)
119 | (:args (vector :scs (descriptor-reg))
120 | (index :scs (immediate unsigned-reg))
121 | ,@(when setterp
122 | `((value :scs (,result-sc) :target result))))
123 | (:arg-types simple-array-unsigned-byte-8
124 | positive-fixnum
125 | ,@(when setterp
126 | `(,result-type)))
127 | ,@(when (and setterp big-endian-p)
128 | `((:temporary (:sc unsigned-reg
129 | :from (:load 0)
130 | :to (:result 0)) temp)))
131 | (:results (result :scs (,result-sc)))
132 | (:result-types ,result-type)
133 | (:generator 3
134 | (let* ((base-disp (- (* vector-data-offset n-word-bytes)
135 | other-pointer-lowtag))
136 | (memref (sc-case index
137 | (immediate
138 | (make-ea :dword :base vector
139 | :disp (+ (tn-value index) base-disp)))
140 | (t
141 | (make-ea :dword :base vector :index index
142 | :disp base-disp)))))
143 | ,@(when (and setterp big-endian-p)
144 | `((inst mov temp value)
145 | (inst bswap temp)))
146 | ,(if setterp
147 | `(inst mov memref ,(if big-endian-p
148 | 'temp
149 | 'value))
150 | '(inst mov result memref))
151 | ,(if setterp
152 | '(move result value)
153 | (when big-endian-p
154 | '(inst bswap result)))))))))
155 | (loop for i from 0 upto #b111
156 | for setterp = (logbitp 2 i)
157 | for signedp = (logbitp 1 i)
158 | for big-endian-p = (logbitp 0 i)
159 | collect (frob setterp signedp big-endian-p) into forms
160 | finally (return `(progn ,@forms))))
161 |
--------------------------------------------------------------------------------
/streams.lisp:
--------------------------------------------------------------------------------
1 | ;;;; streams.lisp -- reading/writing signed/unsigned bytes to streams
2 |
3 | (cl:in-package :nibbles)
4 |
5 | (defun read-n-bytes-into (stream n-bytes v)
6 | (declare (type (integer 2 8) n-bytes))
7 | (dotimes (i n-bytes v)
8 | ;; READ-SEQUENCE would likely be more efficient here, but it does
9 | ;; not have the semantics we want--in particular, the blocking
10 | ;; semantics of READ-SEQUENCE are potentially bad. It's not clear
11 | ;; that READ-BYTE is any better here, though...
12 | (setf (aref v i) (read-byte stream))))
13 |
14 | (declaim (inline read-byte* write-byte*))
15 | (defun read-byte* (stream n-bytes reffer)
16 | (declare (type (integer 2 8) n-bytes))
17 | (let ((v (make-octet-vector n-bytes)))
18 | (declare (dynamic-extent v))
19 | (read-n-bytes-into stream n-bytes v)
20 | (funcall reffer v 0)))
21 |
22 | (defun write-byte* (integer stream n-bytes setter)
23 | (declare (type (integer 2 8) n-bytes))
24 | (let ((v (make-octet-vector n-bytes)))
25 | (declare (dynamic-extent v))
26 | (funcall setter v 0 integer)
27 | (write-sequence v stream)
28 | integer))
29 |
30 | (declaim (inline read-into-vector*))
31 | (defun read-into-vector* (stream vector start end n-bytes reffer)
32 | (declare (type (integer 2 8) n-bytes)
33 | (type function reffer))
34 | (let ((v (make-octet-vector n-bytes)))
35 | (declare (dynamic-extent v))
36 | (loop for i from start below end
37 | do (read-n-bytes-into stream n-bytes v)
38 | (setf (aref vector i) (funcall reffer v 0))
39 | finally (return vector))))
40 |
41 | (defun read-into-list* (stream list start end n-bytes reffer)
42 | (declare (type (integer 2 8) n-bytes)
43 | (type function reffer))
44 | (do ((end (or end (length list)))
45 | (v (make-octet-vector n-bytes))
46 | (rem (nthcdr start list) (rest rem))
47 | (i start (1+ i)))
48 | ((or (endp rem) (>= i end)) list)
49 | (declare (dynamic-extent v))
50 | (read-n-bytes-into stream n-bytes v)
51 | (setf (first rem) (funcall reffer v 0))))
52 |
53 | (declaim (inline read-fresh-sequence))
54 | (defun read-fresh-sequence (result-type stream count
55 | element-type n-bytes reffer)
56 | (ecase result-type
57 | (list
58 | (let ((list (make-list count)))
59 | (read-into-list* stream list 0 count n-bytes reffer)))
60 | (vector
61 | (let ((vector (make-array count :element-type element-type)))
62 | (read-into-vector* stream vector 0 count n-bytes reffer)))))
63 |
64 | (defun write-sequence-with-writer (seq stream start end writer)
65 | (declare (type function writer))
66 | (etypecase seq
67 | (list
68 | (mapc (lambda (e) (funcall writer e stream))
69 | (subseq seq start end))
70 | seq)
71 | (vector
72 | (loop with end = (or end (length seq))
73 | for i from start below end
74 | do (funcall writer (aref seq i) stream)
75 | finally (return seq)))))
76 |
77 | (defun read-into-sequence (seq stream start end n-bytes reffer)
78 | (declare (type (integer 2 8) n-bytes))
79 | (etypecase seq
80 | (list
81 | (read-into-list* stream seq start end n-bytes reffer))
82 | (vector
83 | (let ((end (or end (length seq))))
84 | (read-into-vector* stream seq start end n-bytes reffer)))))
85 |
86 | #.(loop for i from 0 upto #b11111
87 | for bitsize = (ecase (ldb (byte 2 3) i)
88 | (0 16)
89 | (3 24)
90 | (1 32)
91 | (2 64))
92 | for readp = (logbitp 2 i)
93 | for signedp = (logbitp 1 i)
94 | for big-endian-p = (logbitp 0 i)
95 | for name = (stream-ref-fun-name bitsize readp signedp big-endian-p)
96 | for n-bytes = (truncate bitsize 8)
97 | for byte-fun = (if readp
98 | (byte-ref-fun-name bitsize signedp big-endian-p)
99 | (byte-set-fun-name bitsize signedp big-endian-p))
100 | for byte-arglist = (if readp '(stream) '(integer stream))
101 | for subfun = (if readp 'read-byte* 'write-byte*)
102 | for element-type = `(,(if signedp 'signed-byte 'unsigned-byte) ,bitsize)
103 | collect `(progn
104 | ,@(when readp
105 | `((declaim (ftype (function (t) (values ,element-type &optional)) ,name))))
106 | (defun ,name ,byte-arglist
107 | (,subfun ,@byte-arglist ,n-bytes #',byte-fun))) into forms
108 | if readp
109 | collect `(defun ,(stream-seq-fun-name bitsize t signedp big-endian-p)
110 | (result-type stream count)
111 | ,(format-docstring "Return a sequence of type RESULT-TYPE, containing COUNT elements read from STREAM. Each element is a ~D-bit ~:[un~;~]signed integer read in ~:[little~;big~]-endian order. RESULT-TYPE must be either CL:VECTOR or CL:LIST. STREAM must have an element type of (UNSIGNED-BYTE 8)."
112 | bitsize signedp big-endian-p)
113 | (read-fresh-sequence result-type stream count
114 | ',element-type ,n-bytes #',byte-fun)) into forms
115 | else
116 | collect `(defun ,(stream-seq-fun-name bitsize nil signedp big-endian-p)
117 | (seq stream &key (start 0) end)
118 | ,(format-docstring "Write elements from SEQ between START and END as ~D-bit ~:[un~;~]signed integers in ~:[little~;big~]-endian order to STREAM. SEQ may be either a vector or a list. STREAM must have an element type of (UNSIGNED-BYTE 8)."
119 | bitsize signedp big-endian-p)
120 | (write-sequence-with-writer seq stream start end #',name)) into forms
121 | if readp
122 | collect `(defun ,(stream-into-seq-fun-name bitsize signedp big-endian-p)
123 | (seq stream &key (start 0) end)
124 | ,(format-docstring "Destructively modify SEQ by replacing the elements of SEQ between START and END with elements read from STREAM. Each element is a ~D-bit ~:[un~;~]signed integer read in ~:[little~;big~]-endian order. SEQ may be either a vector or a list. STREAM must have an element type of (UNSIGNED-BYTE 8)."
125 | bitsize signedp big-endian-p)
126 | (read-into-sequence seq stream start end ,n-bytes #',byte-fun)) into forms
127 | finally (return `(progn ,@forms)))
128 |
129 | #.(loop for i from 0 upto #b111
130 | for float-type = (if (logbitp 2 i) 'double 'single)
131 | for readp = (logbitp 1 i)
132 | for big-endian-p = (logbitp 0 i)
133 | for name = (stream-float-ref-fun-name float-type readp big-endian-p)
134 | for n-bytes = (ecase float-type (double 8) (single 4))
135 | for single-fun = (if readp
136 | (float-ref-fun-name float-type big-endian-p)
137 | (float-set-fun-name float-type big-endian-p))
138 | for arglist = (if readp '(stream) '(float stream))
139 | for subfun = (if readp 'read-byte* 'write-byte*)
140 | for element-type = (ecase float-type (double 'double-float) (single 'single-float))
141 | collect `(defun ,name ,arglist
142 | (,subfun ,@arglist ,n-bytes #',single-fun)) into forms
143 | if readp
144 | collect `(defun ,(stream-float-seq-fun-name float-type t big-endian-p)
145 | (result-type stream count)
146 | ,(format-docstring "Return a sequence of type RESULT-TYPE, containing COUNT elements read from STREAM. Each element is a ~A read in ~:[little~;big~]-endian byte order. RESULT-TYPE must be either CL:VECTOR or CL:LIST. STREAM must have an element type of (UNSIGNED-BYTE 8)."
147 | element-type big-endian-p)
148 | (read-fresh-sequence result-type stream count
149 | ',element-type ,n-bytes #',single-fun)) into forms
150 | else
151 | collect `(defun ,(stream-float-seq-fun-name float-type nil big-endian-p)
152 | (seq stream &key (start 0) end)
153 | ,(format-docstring "Write elements from SEQ between START and END as ~As in ~:[little~;big~]-endian byte order to STREAM. SEQ may be either a vector or a list. STREAM must have an element type of (UNSIGNED-BYTE 8)."
154 | element-type big-endian-p)
155 | (write-sequence-with-writer seq stream start end #',name)) into forms
156 | if readp
157 | collect `(defun ,(stream-float-into-seq-fun-name float-type big-endian-p)
158 | (seq stream &key (start 0) end)
159 | ,(format-docstring "Destructively modify SEQ by replacing the elements of SEQ between START and END with elements read from STREAM. Each element is a ~A read in ~:[little~;big~]-endian byte order. SEQ may be either a vector or a list. STREAM must have na element type of (UNSIGNED-BYTE 8)."
160 | element-type big-endian-p)
161 | (read-into-sequence seq stream start end ,n-bytes #',single-fun)) into forms
162 | finally (return `(progn ,@forms)))
163 |
--------------------------------------------------------------------------------
/tests.lisp:
--------------------------------------------------------------------------------
1 | ;;;; tests.lisp -- tests for various bits of functionality
2 |
3 | (cl:defpackage :nibbles-tests
4 | (:use :cl))
5 |
6 | (cl:in-package :nibbles-tests)
7 |
8 | ;;; Basic tests for correctness.
9 |
10 | (defun make-byte-combiner (n-bytes big-endian-p)
11 | (let ((count 0)
12 | (buffer 0))
13 | #'(lambda (byte)
14 | (setf buffer
15 | (if big-endian-p
16 | (logior (ash buffer 8) byte)
17 | (let ((x (logior (ash byte (* 8 count)) buffer)))
18 | (if (= count n-bytes)
19 | (ash x -8)
20 | x))))
21 | (unless (= count n-bytes)
22 | (incf count))
23 | (cond
24 | ((= count n-bytes)
25 | (let ((val (ldb (byte (* 8 n-bytes) 0) buffer)))
26 | (multiple-value-prog1 (values val t)
27 | (setf buffer val))))
28 | (t (values 0 nil))))))
29 |
30 | (defun generate-random-octet-vector (n-octets)
31 | (loop with v = (nibbles:make-octet-vector n-octets)
32 | for i from 0 below n-octets
33 | do (setf (aref v i) (random 256))
34 | finally (return v)))
35 |
36 | (defun generate-reffed-values (byte-vector bitsize signedp big-endian-p
37 | &optional (rolling-p t))
38 | (do* ((byte-kind (if signedp 'signed-byte 'unsigned-byte))
39 | (bytesize (truncate bitsize 8))
40 | (n-bytes-to-read (if rolling-p
41 | (length byte-vector)
42 | (* (floor (length byte-vector) bytesize)
43 | bytesize)))
44 | (n-values (if rolling-p
45 | (- (length byte-vector) (1- bytesize))
46 | (truncate n-bytes-to-read bytesize)))
47 | (expected-values (make-array n-values :element-type `(,byte-kind ,bitsize)))
48 | (i 0 (1+ i))
49 | (j 0)
50 | (combiner (make-byte-combiner bytesize big-endian-p)))
51 | ((>= i n-bytes-to-read) expected-values)
52 | (multiple-value-bind (aggregate set-p) (funcall combiner (aref byte-vector i))
53 | (when set-p
54 | (setf (aref expected-values j)
55 | (if (and signedp (logbitp (1- bitsize) aggregate))
56 | (dpb aggregate (byte bitsize 0) -1)
57 | aggregate))
58 | (unless rolling-p
59 | (setf combiner (make-byte-combiner bytesize big-endian-p)))
60 | (incf j)))))
61 |
62 | (defvar *default-n-values* 4096)
63 |
64 | (defun generate-random-test (bitsize signedp big-endian-p
65 | &optional (n-values *default-n-values*))
66 | (let* ((n-bytes (truncate bitsize 8))
67 | (total-octets (+ n-values (1- n-bytes)))
68 | (random-octets (generate-random-octet-vector total-octets))
69 | (expected-vector
70 | (generate-reffed-values random-octets bitsize signedp big-endian-p)))
71 | (values random-octets expected-vector)))
72 |
73 | (defun compile-quietly (form)
74 | (handler-bind ((style-warning #'muffle-warning)
75 | #+sbcl (sb-ext:compiler-note #'muffle-warning))
76 | (compile nil form)))
77 |
78 | (defun ref-test (reffer bitsize signedp big-endian-p
79 | &optional (n-octets *default-n-values*))
80 | (multiple-value-bind (byte-vector expected-vector)
81 | (generate-random-test bitsize signedp big-endian-p n-octets)
82 | (flet ((run-test (reffer)
83 | (loop for i from 0 below n-octets
84 | for j from 0
85 | do (let ((reffed-val (funcall reffer byte-vector i))
86 | (expected-val (aref expected-vector j)))
87 | (unless (= reffed-val expected-val)
88 | (error "wanted ~D, got ~D from ~A"
89 | expected-val reffed-val
90 | (subseq byte-vector i
91 | (+ i (truncate bitsize 8))))))
92 | finally (return :ok))))
93 | (run-test reffer)
94 | (when (typep byte-vector '(simple-array (unsigned-byte 8) (*)))
95 | (let ((compiled (compile-quietly
96 | `(lambda (v i)
97 | (declare (type (simple-array (unsigned-byte 8) (*)) v))
98 | (declare (type (integer 0 #.(1- array-dimension-limit)) i))
99 | (declare (optimize speed (debug 0)))
100 | (,reffer v i)))))
101 | (run-test compiled))))))
102 |
103 | (defun set-test (reffer bitsize signedp big-endian-p
104 | &optional (n-octets *default-n-values*))
105 | ;; We use GET-SETF-EXPANSION to avoid reaching too deeply into
106 | ;; internals. This bit relies on knowing that the writer-form will be
107 | ;; a simple function call whose CAR is the internal setter, but I
108 | ;; think that's a bit better than :: references everywhere.
109 | (multiple-value-bind (vars vals store-vars writer-form reader-form)
110 | (get-setf-expansion `(,reffer x i))
111 | (declare (ignore vars vals store-vars reader-form))
112 | (let ((setter (car writer-form)))
113 | ;; Sanity check.
114 | (unless (eq (symbol-package setter) (find-package :nibbles))
115 | (error "need to update setter tests!"))
116 | (multiple-value-bind (byte-vector expected-vector)
117 | (generate-random-test bitsize signedp big-endian-p n-octets)
118 | (flet ((run-test (setter)
119 | (loop with fill-vec = (let ((v (copy-seq byte-vector)))
120 | (fill v 0)
121 | v)
122 | for i from 0 below n-octets
123 | for j from 0
124 | do (funcall setter fill-vec i (aref expected-vector j))
125 | finally (return
126 | (if (mismatch fill-vec byte-vector)
127 | (error "wanted ~A, got ~A" byte-vector fill-vec)
128 | :ok)))))
129 | (run-test setter)
130 | (when (typep byte-vector '(simple-array (unsigned-byte 8) (*)))
131 | (let ((compiled (compile-quietly
132 | `(lambda (v i new)
133 | (declare (type (simple-array (unsigned-byte 8) (*)) v))
134 | (declare (type (integer 0 #.(1- array-dimension-limit)) i))
135 | (declare (type (,(if signedp 'signed-byte 'unsigned-byte)
136 | ,bitsize) new))
137 | (declare (optimize speed (debug 0)))
138 | (,setter v i new)))))
139 | (run-test compiled))))))))
140 |
141 | ;;; Big-endian integer ref tests
142 |
143 | (rtest:deftest :ub16ref/be
144 | (ref-test 'nibbles:ub16ref/be 16 nil t)
145 | :ok)
146 |
147 | (rtest:deftest :sb16ref/be
148 | (ref-test 'nibbles:sb16ref/be 16 t t)
149 | :ok)
150 |
151 | (rtest:deftest :ub24ref/be
152 | (ref-test 'nibbles:ub24ref/be 24 nil t)
153 | :ok)
154 |
155 | (rtest:deftest :sb24ref/be
156 | (ref-test 'nibbles:sb24ref/be 24 t t)
157 | :ok)
158 |
159 | (rtest:deftest :ub32ref/be
160 | (ref-test 'nibbles:ub32ref/be 32 nil t)
161 | :ok)
162 |
163 | (rtest:deftest :sb32ref/be
164 | (ref-test 'nibbles:sb32ref/be 32 t t)
165 | :ok)
166 |
167 | (rtest:deftest :ub64ref/be
168 | (ref-test 'nibbles:ub64ref/be 64 nil t)
169 | :ok)
170 |
171 | (rtest:deftest :sb64ref/be
172 | (ref-test 'nibbles:sb64ref/be 64 t t)
173 | :ok)
174 |
175 | ;;; Big-endian integer set tests
176 |
177 | (rtest:deftest :ub16set/be
178 | (set-test 'nibbles:ub16ref/be 16 nil t)
179 | :ok)
180 |
181 | (rtest:deftest :sb16set/be
182 | (set-test 'nibbles:sb16ref/be 16 t t)
183 | :ok)
184 |
185 | (rtest:deftest :ub24set/be
186 | (set-test 'nibbles:ub24ref/be 24 nil t)
187 | :ok)
188 |
189 | (rtest:deftest :sb24set/be
190 | (set-test 'nibbles:sb24ref/be 24 t t)
191 | :ok)
192 |
193 | (rtest:deftest :ub32set/be
194 | (set-test 'nibbles:ub32ref/be 32 nil t)
195 | :ok)
196 |
197 | (rtest:deftest :sb32set/be
198 | (set-test 'nibbles:sb32ref/be 32 t t)
199 | :ok)
200 |
201 | (rtest:deftest :ub64set/be
202 | (set-test 'nibbles:ub64ref/be 64 nil t)
203 | :ok)
204 |
205 | (rtest:deftest :sb64set/be
206 | (set-test 'nibbles:sb64ref/be 64 t t)
207 | :ok)
208 |
209 | ;;; Little-endian integer ref tests
210 |
211 | (rtest:deftest :ub16ref/le
212 | (ref-test 'nibbles:ub16ref/le 16 nil nil)
213 | :ok)
214 |
215 | (rtest:deftest :sb16ref/le
216 | (ref-test 'nibbles:sb16ref/le 16 t nil)
217 | :ok)
218 |
219 | (rtest:deftest :ub24ref/le
220 | (ref-test 'nibbles:ub24ref/le 24 nil nil)
221 | :ok)
222 |
223 | (rtest:deftest :sb24ref/le
224 | (ref-test 'nibbles:sb24ref/le 24 t nil)
225 | :ok)
226 |
227 | (rtest:deftest :ub32ref/le
228 | (ref-test 'nibbles:ub32ref/le 32 nil nil)
229 | :ok)
230 |
231 | (rtest:deftest :sb32ref/le
232 | (ref-test 'nibbles:sb32ref/le 32 t nil)
233 | :ok)
234 |
235 | (rtest:deftest :ub64ref/le
236 | (ref-test 'nibbles:ub64ref/le 64 nil nil)
237 | :ok)
238 |
239 | (rtest:deftest :sb64ref/le
240 | (ref-test 'nibbles:sb64ref/le 64 t nil)
241 | :ok)
242 |
243 | ;;; Little-endian integer set tests
244 |
245 | (rtest:deftest :ub16set/le
246 | (set-test 'nibbles:ub16ref/le 16 nil nil)
247 | :ok)
248 |
249 | (rtest:deftest :sb16set/le
250 | (set-test 'nibbles:sb16ref/le 16 t nil)
251 | :ok)
252 |
253 | (rtest:deftest :ub24set/le
254 | (set-test 'nibbles:ub24ref/le 24 nil nil)
255 | :ok)
256 |
257 | (rtest:deftest :sb24set/le
258 | (set-test 'nibbles:sb24ref/le 24 t nil)
259 | :ok)
260 |
261 | (rtest:deftest :ub32set/le
262 | (set-test 'nibbles:ub32ref/le 32 nil nil)
263 | :ok)
264 |
265 | (rtest:deftest :sb32set/le
266 | (set-test 'nibbles:sb32ref/le 32 t nil)
267 | :ok)
268 |
269 | (rtest:deftest :ub64set/le
270 | (set-test 'nibbles:ub64ref/le 64 nil nil)
271 | :ok)
272 |
273 | (rtest:deftest :sb64set/le
274 | (set-test 'nibbles:sb64ref/le 64 t nil)
275 | :ok)
276 |
277 | ;;; Floating point.
278 |
279 | (defun normal-float-p (bits bitsize)
280 | "Return true when BITS represents a IEEE floating point number that is
281 | neither an infinity nor a NaN. Additionally, for CLISP, the number may not be
282 | denormalized."
283 | (ecase bitsize
284 | (32 (let ((exponent (ldb (byte 8 23) bits)))
285 | (and (/= exponent 255) #+clisp (/= exponent 0))))
286 | (64 (let ((exponent (ldb (byte 11 52) bits)))
287 | (and (/= exponent 2047) #+clisp (/= exponent 0))))))
288 |
289 | (defun random-float-bits (bitsize)
290 | (let ((bits (random (expt 2 bitsize))))
291 | (if (normal-float-p bits bitsize)
292 | bits
293 | (random-float-bits bitsize))))
294 |
295 | (defun generate-random-float-vector (n-floats bitsize big-endian-p)
296 | (let* ((bytesize (truncate bitsize 8))
297 | (octets (* n-floats bytesize))
298 | (v (nibbles:make-octet-vector octets)))
299 | (loop for i from 0 below octets by bytesize do
300 | (let ((bits (random-float-bits bitsize)))
301 | (ecase bitsize
302 | (32 (if big-endian-p
303 | (setf (nibbles:ub32ref/be v i) bits)
304 | (setf (nibbles:ub32ref/le v i) bits)))
305 | (64 (if big-endian-p
306 | (setf (nibbles:ub64ref/be v i) bits)
307 | (setf (nibbles:ub64ref/le v i) bits))))))
308 | v))
309 |
310 | (defun generate-reffed-floats (byte-vector n-floats bitsize big-endian-p)
311 | (let ((bytesize (truncate bitsize 8))
312 | (expected-values
313 | (make-array n-floats :element-type (if (= bitsize 32) 'single-float 'double-float))))
314 | (loop for i from 0 by bytesize
315 | for j from 0 below n-floats
316 | do (let ((bits
317 | (ecase bitsize
318 | (32 (if big-endian-p
319 | (nibbles:ub32ref/be byte-vector i)
320 | (nibbles:ub32ref/le byte-vector i)))
321 | (64 (if big-endian-p
322 | (nibbles:ub64ref/be byte-vector i)
323 | (nibbles:ub64ref/le byte-vector i))))))
324 | (setf (aref expected-values j)
325 | (ecase bitsize
326 | (32 (nibbles::make-single-float bits))
327 | (64 (nibbles::make-double-float (ldb (byte 32 32) bits)
328 | (ldb (byte 32 0) bits)))))))
329 | expected-values))
330 |
331 | (defvar *default-float-values* 4096)
332 |
333 | (defun generate-random-float-test (bitsize big-endian-p
334 | &optional (n-floats *default-float-values*))
335 | (let* ((random-octets (generate-random-float-vector n-floats bitsize big-endian-p))
336 | (expected-vector (generate-reffed-floats random-octets n-floats bitsize big-endian-p)))
337 | (values random-octets expected-vector)))
338 |
339 | (defun ref-float-test (reffer bitsize big-endian-p
340 | &optional (n-floats *default-float-values*))
341 | (multiple-value-bind (byte-vector expected-vector)
342 | (generate-random-float-test bitsize big-endian-p n-floats)
343 | (flet ((run-test (reffer)
344 | (let ((bytesize (truncate bitsize 8)))
345 | (loop for i from 0 by bytesize
346 | for j from 0 below n-floats
347 | do (let ((reffed-val (funcall reffer byte-vector i))
348 | (expected-val (aref expected-vector j)))
349 | (unless (= reffed-val expected-val)
350 | (error "wanted ~D, got ~D from ~A"
351 | expected-val reffed-val
352 | (subseq byte-vector i (+ i bytesize)))))
353 | finally (return :ok)))))
354 | (run-test reffer)
355 | (when (typep byte-vector '(simple-array (unsigned-byte 8) (*)))
356 | (let ((compiled (compile-quietly
357 | `(lambda (v i)
358 | (declare (type (simple-array (unsigned-byte 8) (*)) v))
359 | (declare (type (integer 0 #.(1- array-dimension-limit)) i))
360 | (declare (optimize speed (debug 0)))
361 | (,reffer v i)))))
362 | (run-test compiled))))))
363 |
364 | (defun set-float-test (reffer bitsize big-endian-p
365 | &optional (n-floats *default-float-values*))
366 | ;; We use GET-SETF-EXPANSION to avoid reaching too deeply into
367 | ;; internals. This bit relies on knowing that the writer-form will be
368 | ;; a simple function call whose CAR is the internal setter, but I
369 | ;; think that's a bit better than :: references everywhere.
370 | (multiple-value-bind (vars vals store-vars writer-form reader-form)
371 | (get-setf-expansion `(,reffer x i))
372 | (declare (ignore vars vals store-vars reader-form))
373 | (let ((setter (car writer-form)))
374 | ;; Sanity check.
375 | (unless (eq (symbol-package setter) (find-package :nibbles))
376 | (error "need to update setter tests!"))
377 | (multiple-value-bind (byte-vector expected-vector)
378 | (generate-random-float-test bitsize big-endian-p n-floats)
379 | (flet ((run-test (setter)
380 | (let ((bytesize (truncate bitsize 8)))
381 | (loop with fill-vec = (let ((v (copy-seq byte-vector)))
382 | (fill v 0)
383 | v)
384 | for i from 0 by bytesize
385 | for j from 0 below n-floats
386 | do (funcall setter fill-vec i (aref expected-vector j))
387 | finally (return
388 | (if (mismatch fill-vec byte-vector)
389 | (error "wanted ~A, got ~A" byte-vector fill-vec)
390 | :ok))))))
391 | (run-test setter)
392 | (when (typep byte-vector '(simple-array (unsigned-byte 8) (*)))
393 | (let ((compiled (compile-quietly
394 | `(lambda (v i new)
395 | (declare (type (simple-array (unsigned-byte 8) (*)) v))
396 | (declare (type (integer 0 #.(1- array-dimension-limit)) i))
397 | (declare (type ,(if (= bitsize 32) 'single-float 'double-float)
398 | new))
399 | (declare (optimize speed (debug 0)))
400 | (,setter v i new)))))
401 | (run-test compiled))))))))
402 |
403 | ;;; Big-endian float ref tests
404 |
405 | (rtest:deftest :ieee-single-ref/be
406 | (ref-float-test 'nibbles:ieee-single-ref/be 32 t)
407 | :ok)
408 |
409 | (rtest:deftest :ieee-double-ref/be
410 | (ref-float-test 'nibbles:ieee-double-ref/be 64 t)
411 | :ok)
412 |
413 | ;;; Big-endian float set tests
414 |
415 | (rtest:deftest :ieee-single-set/be
416 | (set-float-test 'nibbles:ieee-single-ref/be 32 t)
417 | :ok)
418 |
419 | (rtest:deftest :ieee-double-set/be
420 | (set-float-test 'nibbles:ieee-double-ref/be 64 t)
421 | :ok)
422 |
423 | ;;; Little-endian float ref tests
424 |
425 | (rtest:deftest :ieee-single-ref/le
426 | (ref-float-test 'nibbles:ieee-single-ref/le 32 nil)
427 | :ok)
428 |
429 | (rtest:deftest :ieee-double-ref/le
430 | (ref-float-test 'nibbles:ieee-double-ref/le 64 nil)
431 | :ok)
432 |
433 | ;;; Little-endian float set tests
434 |
435 | (rtest:deftest :ieee-single-set/le
436 | (set-float-test 'nibbles:ieee-single-ref/le 32 nil)
437 | :ok)
438 |
439 | (rtest:deftest :ieee-double-set/le
440 | (set-float-test 'nibbles:ieee-double-ref/le 64 nil)
441 | :ok)
442 |
443 |
444 | ;;; Stream reading tests
445 |
446 | (defvar *path* #.*compile-file-truename*)
447 |
448 | (defun read-file-as-octets (pathname)
449 | (with-open-file (stream pathname :direction :input
450 | :element-type '(unsigned-byte 8))
451 | (let ((v (nibbles:make-octet-vector (file-length stream))))
452 | (read-sequence v stream)
453 | v)))
454 |
455 | (defun read-test (reader bitsize signedp big-endian-p)
456 | (let* ((pathname *path*)
457 | (file-contents (read-file-as-octets pathname))
458 | (expected-values (generate-reffed-values file-contents bitsize
459 | signedp big-endian-p)))
460 | (with-open-file (stream pathname :direction :input
461 | :element-type '(unsigned-byte 8))
462 | (loop with n-values = (length expected-values)
463 | for i from 0 below n-values
464 | do (file-position stream i)
465 | (let ((read-value (funcall reader stream))
466 | (expected-value (aref expected-values i)))
467 | (unless (= read-value expected-value)
468 | (return :bad)))
469 | finally (return :ok)))))
470 |
471 | (defun read-sequence-test (result-type reader bitsize signedp big-endian-p)
472 | (let* ((pathname *path*)
473 | (file-contents (subseq (read-file-as-octets pathname) 0 8))
474 | (expected-values (generate-reffed-values file-contents bitsize
475 | signedp big-endian-p nil)))
476 | (with-open-file (stream pathname :direction :input
477 | :element-type '(unsigned-byte 8))
478 | (let* ((n-values (truncate (length file-contents)
479 | (truncate bitsize 8)))
480 | (read-values (funcall reader result-type stream n-values)))
481 | (if (or (not (typep read-values result-type))
482 | (mismatch read-values expected-values))
483 | :bad
484 | :ok)))))
485 |
486 | (rtest:deftest :read-ub16/be
487 | (read-test 'nibbles:read-ub16/be 16 nil t)
488 | :ok)
489 |
490 | (rtest:deftest :read-sb16/be
491 | (read-test 'nibbles:read-sb16/be 16 t t)
492 | :ok)
493 |
494 | (rtest:deftest :read-ub24/be
495 | (read-test 'nibbles:read-ub24/be 24 nil t)
496 | :ok)
497 |
498 | (rtest:deftest :read-sb24/be
499 | (read-test 'nibbles:read-sb24/be 24 t t)
500 | :ok)
501 |
502 | (rtest:deftest :read-ub32/be
503 | (read-test 'nibbles:read-ub32/be 32 nil t)
504 | :ok)
505 |
506 | (rtest:deftest :read-sb32/be
507 | (read-test 'nibbles:read-sb32/be 32 t t)
508 | :ok)
509 |
510 | (rtest:deftest :read-ub64/be
511 | (read-test 'nibbles:read-ub64/be 64 nil t)
512 | :ok)
513 |
514 | (rtest:deftest :read-sb64/be
515 | (read-test 'nibbles:read-sb64/be 64 t t)
516 | :ok)
517 |
518 | (rtest:deftest :read-ub16/le
519 | (read-test 'nibbles:read-ub16/le 16 nil nil)
520 | :ok)
521 |
522 | (rtest:deftest :read-sb16/le
523 | (read-test 'nibbles:read-sb16/le 16 t nil)
524 | :ok)
525 |
526 | (rtest:deftest :read-ub32/le
527 | (read-test 'nibbles:read-ub32/le 32 nil nil)
528 | :ok)
529 |
530 | (rtest:deftest :read-sb32/le
531 | (read-test 'nibbles:read-sb32/le 32 t nil)
532 | :ok)
533 |
534 | (rtest:deftest :read-ub64/le
535 | (read-test 'nibbles:read-ub64/le 64 nil nil)
536 | :ok)
537 |
538 | (rtest:deftest :read-sb64/le
539 | (read-test 'nibbles:read-sb64/le 64 t nil)
540 | :ok)
541 |
542 | (rtest:deftest :read-ub16/be-vector
543 | (read-sequence-test 'vector 'nibbles:read-ub16/be-sequence 16 nil t)
544 | :ok)
545 |
546 | (rtest:deftest :read-sb16/be-vector
547 | (read-sequence-test 'vector 'nibbles:read-sb16/be-sequence 16 t t)
548 | :ok)
549 |
550 | (rtest:deftest :read-ub24/be-vector
551 | (read-sequence-test 'vector 'nibbles:read-ub24/be-sequence 24 nil t)
552 | :ok)
553 |
554 | (rtest:deftest :read-sb24/be-vector
555 | (read-sequence-test 'vector 'nibbles:read-sb24/be-sequence 24 t t)
556 | :ok)
557 |
558 | (rtest:deftest :read-ub32/be-vector
559 | (read-sequence-test 'vector 'nibbles:read-ub32/be-sequence 32 nil t)
560 | :ok)
561 |
562 | (rtest:deftest :read-sb32/be-vector
563 | (read-sequence-test 'vector 'nibbles:read-sb32/be-sequence 32 t t)
564 | :ok)
565 |
566 | (rtest:deftest :read-ub64/be-vector
567 | (read-sequence-test 'vector 'nibbles:read-ub64/be-sequence 64 nil t)
568 | :ok)
569 |
570 | (rtest:deftest :read-sb64/be-vector
571 | (read-sequence-test 'vector 'nibbles:read-sb64/be-sequence 64 t t)
572 | :ok)
573 |
574 | (rtest:deftest :read-ub16/le-vector
575 | (read-sequence-test 'vector 'nibbles:read-ub16/le-sequence 16 nil nil)
576 | :ok)
577 |
578 | (rtest:deftest :read-sb16/le-vector
579 | (read-sequence-test 'vector 'nibbles:read-sb16/le-sequence 16 t nil)
580 | :ok)
581 |
582 | (rtest:deftest :read-ub24/le-vector
583 | (read-sequence-test 'vector 'nibbles:read-ub24/le-sequence 24 nil nil)
584 | :ok)
585 |
586 | (rtest:deftest :read-sb24/le-vector
587 | (read-sequence-test 'vector 'nibbles:read-sb24/le-sequence 24 t nil)
588 | :ok)
589 |
590 | (rtest:deftest :read-ub32/le-vector
591 | (read-sequence-test 'vector 'nibbles:read-ub32/le-sequence 32 nil nil)
592 | :ok)
593 |
594 | (rtest:deftest :read-sb32/le-vector
595 | (read-sequence-test 'vector 'nibbles:read-sb32/le-sequence 32 t nil)
596 | :ok)
597 |
598 | (rtest:deftest :read-ub64/le-vector
599 | (read-sequence-test 'vector 'nibbles:read-ub64/le-sequence 64 nil nil)
600 | :ok)
601 |
602 | (rtest:deftest :read-sb64/le-vector
603 | (read-sequence-test 'vector 'nibbles:read-sb64/le-sequence 64 t nil)
604 | :ok)
605 |
606 | (rtest:deftest :read-ub16/be-list
607 | (read-sequence-test 'list 'nibbles:read-ub16/be-sequence 16 nil t)
608 | :ok)
609 |
610 | (rtest:deftest :read-sb16/be-list
611 | (read-sequence-test 'list 'nibbles:read-sb16/be-sequence 16 t t)
612 | :ok)
613 |
614 | (rtest:deftest :read-ub24/be-list
615 | (read-sequence-test 'list 'nibbles:read-ub24/be-sequence 24 nil t)
616 | :ok)
617 |
618 | (rtest:deftest :read-sb24/be-list
619 | (read-sequence-test 'list 'nibbles:read-sb24/be-sequence 24 t t)
620 | :ok)
621 |
622 | (rtest:deftest :read-ub32/be-list
623 | (read-sequence-test 'list 'nibbles:read-ub32/be-sequence 32 nil t)
624 | :ok)
625 |
626 | (rtest:deftest :read-sb32/be-list
627 | (read-sequence-test 'list 'nibbles:read-sb32/be-sequence 32 t t)
628 | :ok)
629 |
630 | (rtest:deftest :read-ub64/be-list
631 | (read-sequence-test 'list 'nibbles:read-ub64/be-sequence 64 nil t)
632 | :ok)
633 |
634 | (rtest:deftest :read-sb64/be-list
635 | (read-sequence-test 'list 'nibbles:read-sb64/be-sequence 64 t t)
636 | :ok)
637 |
638 | (rtest:deftest :read-ub16/le-list
639 | (read-sequence-test 'list 'nibbles:read-ub16/le-sequence 16 nil nil)
640 | :ok)
641 |
642 | (rtest:deftest :read-sb16/le-list
643 | (read-sequence-test 'list 'nibbles:read-sb16/le-sequence 16 t nil)
644 | :ok)
645 |
646 | (rtest:deftest :read-ub24/le-list
647 | (read-sequence-test 'list 'nibbles:read-ub24/le-sequence 24 nil nil)
648 | :ok)
649 |
650 | (rtest:deftest :read-sb24/le-list
651 | (read-sequence-test 'list 'nibbles:read-sb24/le-sequence 24 t nil)
652 | :ok)
653 |
654 | (rtest:deftest :read-ub32/le-list
655 | (read-sequence-test 'list 'nibbles:read-ub32/le-sequence 32 nil nil)
656 | :ok)
657 |
658 | (rtest:deftest :read-sb32/le-list
659 | (read-sequence-test 'list 'nibbles:read-sb32/le-sequence 32 t nil)
660 | :ok)
661 |
662 | (rtest:deftest :read-ub64/le-list
663 | (read-sequence-test 'list 'nibbles:read-ub64/le-sequence 64 nil nil)
664 | :ok)
665 |
666 | (rtest:deftest :read-sb64/le-list
667 | (read-sequence-test 'list 'nibbles:read-sb64/le-sequence 64 t nil)
668 | :ok)
669 |
670 | ;;; Stream writing tests
671 |
672 | (defvar *output-directory*
673 | (merge-pathnames (make-pathname :name nil :type nil
674 | :directory '(:relative "test-output"))
675 | (make-pathname :directory (pathname-directory *path*))))
676 |
677 | (defun write-test (writer bitsize signedp big-endian-p)
678 | (multiple-value-bind (byte-vector expected-values)
679 | (generate-random-test bitsize signedp big-endian-p)
680 | (let ((tmpfile (make-pathname :name "tmp" :defaults *output-directory*)))
681 | (ensure-directories-exist tmpfile)
682 | (with-open-file (stream tmpfile :direction :output
683 | :element-type '(unsigned-byte 8)
684 | :if-does-not-exist :create
685 | :if-exists :supersede)
686 | (loop with n-values = (length expected-values)
687 | for i from 0 below n-values
688 | do (file-position stream i)
689 | (funcall writer (aref expected-values i) stream)))
690 | (let ((file-contents (read-file-as-octets tmpfile)))
691 | (delete-file tmpfile)
692 | (if (mismatch byte-vector file-contents)
693 | :bad
694 | :ok)))))
695 |
696 | (defun read-sequence-from-file (filename seq-type reader n-values)
697 | (with-open-file (stream filename :direction :input
698 | :element-type '(unsigned-byte 8)
699 | :if-does-not-exist :error)
700 | (funcall reader seq-type stream n-values)))
701 |
702 | (defun write-sequence-test (seq-type reader writer
703 | bitsize signedp big-endian-p)
704 | (multiple-value-bind (byte-vector expected-values)
705 | (generate-random-test bitsize signedp big-endian-p)
706 | (declare (ignore byte-vector))
707 | (let ((tmpfile (make-pathname :name "tmp" :defaults *output-directory*))
708 | (values-seq (coerce expected-values seq-type)))
709 | (ensure-directories-exist tmpfile)
710 | (flet ((run-random-test (values expected-start expected-end)
711 | (with-open-file (stream tmpfile :direction :output
712 | :element-type '(unsigned-byte 8)
713 | :if-does-not-exist :create
714 | :if-exists :supersede)
715 | (funcall writer values stream :start expected-start
716 | :end expected-end))
717 | (let ((file-contents (read-sequence-from-file tmpfile
718 | seq-type
719 | reader
720 | (- expected-end expected-start))))
721 | (mismatch values file-contents
722 | :start1 expected-start
723 | :end1 expected-end))))
724 | (let* ((block-size (truncate (length expected-values) 4))
725 | (upper-quartile (* block-size 3)))
726 | (unwind-protect
727 | (loop repeat 32
728 | when (run-random-test values-seq (random block-size)
729 | (+ upper-quartile
730 | (random block-size)))
731 | do (return :bad)
732 | finally (return :ok))
733 | (delete-file tmpfile)))))))
734 |
735 | (rtest:deftest :write-ub16/be
736 | (write-test 'nibbles:write-ub16/be 16 nil t)
737 | :ok)
738 |
739 | (rtest:deftest :write-sb16/be
740 | (write-test 'nibbles:write-sb16/be 16 t t)
741 | :ok)
742 |
743 | (rtest:deftest :write-ub24/be
744 | (write-test 'nibbles:write-ub24/be 24 nil t)
745 | :ok)
746 |
747 | (rtest:deftest :write-sb24/be
748 | (write-test 'nibbles:write-sb24/be 24 t t)
749 | :ok)
750 |
751 | (rtest:deftest :write-ub32/be
752 | (write-test 'nibbles:write-ub32/be 32 nil t)
753 | :ok)
754 |
755 | (rtest:deftest :write-sb32/be
756 | (write-test 'nibbles:write-sb32/be 32 t t)
757 | :ok)
758 |
759 | (rtest:deftest :write-ub64/be
760 | (write-test 'nibbles:write-ub64/be 64 nil t)
761 | :ok)
762 |
763 | (rtest:deftest :write-sb64/be
764 | (write-test 'nibbles:write-sb64/be 64 t t)
765 | :ok)
766 |
767 | (rtest:deftest :write-ub16/le
768 | (write-test 'nibbles:write-ub16/le 16 nil nil)
769 | :ok)
770 |
771 | (rtest:deftest :write-sb16/le
772 | (write-test 'nibbles:write-sb16/le 16 t nil)
773 | :ok)
774 |
775 | (rtest:deftest :write-ub24/le
776 | (write-test 'nibbles:write-ub24/le 24 nil nil)
777 | :ok)
778 |
779 | (rtest:deftest :write-sb24/le
780 | (write-test 'nibbles:write-sb24/le 24 t nil)
781 | :ok)
782 |
783 | (rtest:deftest :write-ub32/le
784 | (write-test 'nibbles:write-ub32/le 32 nil nil)
785 | :ok)
786 |
787 | (rtest:deftest :write-sb32/le
788 | (write-test 'nibbles:write-sb32/le 32 t nil)
789 | :ok)
790 |
791 | (rtest:deftest :write-ub64/le
792 | (write-test 'nibbles:write-ub64/le 64 nil nil)
793 | :ok)
794 |
795 | (rtest:deftest :write-sb64/le
796 | (write-test 'nibbles:write-sb64/le 64 t nil)
797 | :ok)
798 |
799 | (rtest:deftest :write-ub16/be-vector
800 | (write-sequence-test 'vector
801 | 'nibbles:read-ub16/be-sequence
802 | 'nibbles:write-ub16/be-sequence 16 nil t)
803 | :ok)
804 |
805 | (rtest:deftest :write-sb16/be-vector
806 | (write-sequence-test 'vector
807 | 'nibbles:read-sb16/be-sequence
808 | 'nibbles:write-sb16/be-sequence 16 t t)
809 | :ok)
810 |
811 | (rtest:deftest :write-ub24/be-vector
812 | (write-sequence-test 'vector
813 | 'nibbles:read-ub24/be-sequence
814 | 'nibbles:write-ub24/be-sequence 24 nil t)
815 | :ok)
816 |
817 | (rtest:deftest :write-sb24/be-vector
818 | (write-sequence-test 'vector
819 | 'nibbles:read-sb24/be-sequence
820 | 'nibbles:write-sb24/be-sequence 24 t t)
821 | :ok)
822 |
823 | (rtest:deftest :write-ub32/be-vector
824 | (write-sequence-test 'vector
825 | 'nibbles:read-ub32/be-sequence
826 | 'nibbles:write-ub32/be-sequence 32 nil t)
827 | :ok)
828 |
829 | (rtest:deftest :write-sb32/be-vector
830 | (write-sequence-test 'vector
831 | 'nibbles:read-sb32/be-sequence
832 | 'nibbles:write-sb32/be-sequence 32 t t)
833 | :ok)
834 |
835 | (rtest:deftest :write-ub64/be-vector
836 | (write-sequence-test 'vector
837 | 'nibbles:read-ub64/be-sequence
838 | 'nibbles:write-ub64/be-sequence 64 nil t)
839 | :ok)
840 |
841 | (rtest:deftest :write-sb64/be-vector
842 | (write-sequence-test 'vector
843 | 'nibbles:read-sb64/be-sequence
844 | 'nibbles:write-sb64/be-sequence 64 t t)
845 | :ok)
846 |
847 | (rtest:deftest :write-ub16/le-vector
848 | (write-sequence-test 'vector
849 | 'nibbles:read-ub16/le-sequence
850 | 'nibbles:write-ub16/le-sequence 16 nil nil)
851 | :ok)
852 |
853 | (rtest:deftest :write-sb16/le-vector
854 | (write-sequence-test 'vector
855 | 'nibbles:read-sb16/le-sequence
856 | 'nibbles:write-sb16/le-sequence 16 t nil)
857 | :ok)
858 |
859 | (rtest:deftest :write-ub24/le-vector
860 | (write-sequence-test 'vector
861 | 'nibbles:read-ub24/le-sequence
862 | 'nibbles:write-ub24/le-sequence 24 nil nil)
863 | :ok)
864 |
865 | (rtest:deftest :write-sb24/le-vector
866 | (write-sequence-test 'vector
867 | 'nibbles:read-sb24/le-sequence
868 | 'nibbles:write-sb24/le-sequence 24 t nil)
869 | :ok)
870 |
871 | (rtest:deftest :write-ub32/le-vector
872 | (write-sequence-test 'vector
873 | 'nibbles:read-ub32/le-sequence
874 | 'nibbles:write-ub32/le-sequence 32 nil nil)
875 | :ok)
876 |
877 | (rtest:deftest :write-sb32/le-vector
878 | (write-sequence-test 'vector
879 | 'nibbles:read-sb32/le-sequence
880 | 'nibbles:write-sb32/le-sequence 32 t nil)
881 | :ok)
882 |
883 | (rtest:deftest :write-ub64/le-vector
884 | (write-sequence-test 'vector
885 | 'nibbles:read-ub64/le-sequence
886 | 'nibbles:write-ub64/le-sequence 64 nil nil)
887 | :ok)
888 |
889 | (rtest:deftest :write-sb64/le-vector
890 | (write-sequence-test 'vector
891 | 'nibbles:read-sb64/le-sequence
892 | 'nibbles:write-sb64/le-sequence 64 t nil)
893 | :ok)
894 |
895 | (rtest:deftest :write-ub16/be-list
896 | (write-sequence-test 'list
897 | 'nibbles:read-ub16/be-sequence
898 | 'nibbles:write-ub16/be-sequence 16 nil t)
899 | :ok)
900 |
901 | (rtest:deftest :write-sb16/be-list
902 | (write-sequence-test 'list
903 | 'nibbles:read-sb16/be-sequence
904 | 'nibbles:write-sb16/be-sequence 16 t t)
905 | :ok)
906 |
907 | (rtest:deftest :write-ub24/be-list
908 | (write-sequence-test 'list
909 | 'nibbles:read-ub24/be-sequence
910 | 'nibbles:write-ub24/be-sequence 24 nil t)
911 | :ok)
912 |
913 | (rtest:deftest :write-sb24/be-list
914 | (write-sequence-test 'list
915 | 'nibbles:read-sb24/be-sequence
916 | 'nibbles:write-sb24/be-sequence 24 t t)
917 | :ok)
918 |
919 | (rtest:deftest :write-ub32/be-list
920 | (write-sequence-test 'list
921 | 'nibbles:read-ub32/be-sequence
922 | 'nibbles:write-ub32/be-sequence 32 nil t)
923 | :ok)
924 |
925 | (rtest:deftest :write-sb32/be-list
926 | (write-sequence-test 'list
927 | 'nibbles:read-sb32/be-sequence
928 | 'nibbles:write-sb32/be-sequence 32 t t)
929 | :ok)
930 |
931 | (rtest:deftest :write-ub64/be-list
932 | (write-sequence-test 'list
933 | 'nibbles:read-ub64/be-sequence
934 | 'nibbles:write-ub64/be-sequence 64 nil t)
935 | :ok)
936 |
937 | (rtest:deftest :write-sb64/be-list
938 | (write-sequence-test 'list
939 | 'nibbles:read-sb64/be-sequence
940 | 'nibbles:write-sb64/be-sequence 64 t t)
941 | :ok)
942 |
943 | (rtest:deftest :write-ub16/le-list
944 | (write-sequence-test 'list
945 | 'nibbles:read-ub16/le-sequence
946 | 'nibbles:write-ub16/le-sequence 16 nil nil)
947 | :ok)
948 |
949 | (rtest:deftest :write-sb16/le-list
950 | (write-sequence-test 'list
951 | 'nibbles:read-sb16/le-sequence
952 | 'nibbles:write-sb16/le-sequence 16 t nil)
953 | :ok)
954 |
955 | (rtest:deftest :write-ub24/le-list
956 | (write-sequence-test 'list
957 | 'nibbles:read-ub24/le-sequence
958 | 'nibbles:write-ub24/le-sequence 24 nil nil)
959 | :ok)
960 |
961 | (rtest:deftest :write-sb24/le-list
962 | (write-sequence-test 'list
963 | 'nibbles:read-sb24/le-sequence
964 | 'nibbles:write-sb24/le-sequence 24 t nil)
965 | :ok)
966 |
967 | (rtest:deftest :write-ub32/le-list
968 | (write-sequence-test 'list
969 | 'nibbles:read-ub32/le-sequence
970 | 'nibbles:write-ub32/le-sequence 32 nil nil)
971 | :ok)
972 |
973 | (rtest:deftest :write-sb32/le-list
974 | (write-sequence-test 'list
975 | 'nibbles:read-sb32/le-sequence
976 | 'nibbles:write-sb32/le-sequence 32 t nil)
977 | :ok)
978 |
979 | (rtest:deftest :write-ub64/le-list
980 | (write-sequence-test 'list
981 | 'nibbles:read-ub64/le-sequence
982 | 'nibbles:write-ub64/le-sequence 64 nil nil)
983 | :ok)
984 |
985 | (rtest:deftest :write-sb64/le-list
986 | (write-sequence-test 'list
987 | 'nibbles:read-sb64/le-sequence
988 | 'nibbles:write-sb64/le-sequence 64 t nil)
989 | :ok)
990 |
--------------------------------------------------------------------------------
/types.lisp:
--------------------------------------------------------------------------------
1 | ;;;; types.lisp -- various useful types
2 |
3 | (cl:in-package :nibbles)
4 |
5 | (deftype octet ()
6 | '(unsigned-byte 8))
7 |
8 | (deftype index ()
9 | '(mod #.array-dimension-limit))
10 |
11 |
12 | ;;; Type `octet-vector' and constructors
13 | ;;
14 |
15 | (deftype octet-vector (&optional (length '*))
16 | `(array octet (,length)))
17 |
18 | (declaim (ftype (function (index &key (:initial-element octet)) (values octet-vector &optional))
19 | make-octet-vector)
20 | (inline make-octet-vector))
21 |
22 | (defun make-octet-vector (count
23 | &key
24 | (initial-element 0))
25 | "Make and return an `octet-vector' with COUNT elements.
26 |
27 | If supplied, INITIAL-ELEMENT is used to populate the vector. The value
28 | of INITIAL-ELEMENT has to of type `octet'. "
29 | (make-array count
30 | :element-type 'octet
31 | :initial-element initial-element))
32 |
33 | (declaim (ftype (function (&rest octet) (values octet-vector &optional))
34 | octet-vector)
35 | (inline octet-vector))
36 |
37 | (defun octet-vector (&rest args)
38 | "Make and return an `octet-vector' containing the elements ARGS.
39 | ARGS have to be of type `octet'."
40 | (make-array (length args)
41 | :element-type 'octet
42 | :initial-contents args
43 | :adjustable nil
44 | :fill-pointer nil))
45 |
46 |
47 | ;;; Type `simple-octet-vector'
48 | ;;
49 |
50 | (deftype simple-octet-vector (&optional (length '*))
51 | #+(or sbcl cmu) `(simple-array octet (,length))
52 | #-(or sbcl cmu) `(array octet (,length)))
53 |
--------------------------------------------------------------------------------
/vectors.lisp:
--------------------------------------------------------------------------------
1 | ;;;; vectors.lisp -- signed/unsigned byte accessors
2 |
3 | (cl:in-package :nibbles)
4 |
5 | (declaim (inline array-data-and-offsets))
6 | (defun array-data-and-offsets (v start end)
7 | "Like ARRAY-DISPLACEMENT, only more useful."
8 | #+cmu
9 | (lisp::with-array-data ((v v) (start start) (end end))
10 | (values v start end))
11 | #+sbcl
12 | (sb-kernel:with-array-data ((v v) (start start) (end end))
13 | (values v start end))
14 | #-(or cmu sbcl)
15 | (values v start (or end (length v))))
16 |
17 | (macrolet ((define-fetcher (bitsize signedp big-endian-p)
18 | (let ((ref-name (byte-ref-fun-name bitsize signedp big-endian-p))
19 | (bytes (truncate bitsize 8)))
20 | `(defun ,ref-name (vector index)
21 | (declare (type octet-vector vector))
22 | (declare (type (integer 0 ,(- array-dimension-limit bytes)) index))
23 | (multiple-value-bind (vector start end)
24 | (array-data-and-offsets vector index (+ index ,bytes))
25 | #+sbcl (declare (optimize (sb-c::insert-array-bounds-checks 0)))
26 | (declare (type (integer 0 ,(- array-dimension-limit bytes)) start))
27 | (declare (ignore end))
28 | ,(ref-form 'vector 'start bytes signedp big-endian-p)))))
29 | (define-storer (bitsize signedp big-endian-p)
30 | (let ((ref-name (byte-ref-fun-name bitsize signedp big-endian-p))
31 | (set-name (byte-set-fun-name bitsize signedp big-endian-p))
32 | (bytes (truncate bitsize 8)))
33 | `(progn
34 | (defun ,set-name (vector index value)
35 | (declare (type octet-vector vector))
36 | (declare (type (integer 0 ,(- array-dimension-limit bytes)) index))
37 | (declare (type (,(if signedp
38 | 'signed-byte
39 | 'unsigned-byte) ,bitsize) value))
40 | (multiple-value-bind (vector start end)
41 | (array-data-and-offsets vector index (+ index ,bytes))
42 | #+sbcl (declare (optimize (sb-c::insert-array-bounds-checks 0)))
43 | (declare (type (integer 0 ,(- array-dimension-limit bytes)) start))
44 | (declare (ignore end))
45 | ,(set-form 'vector 'start 'value bytes big-endian-p)))
46 | (defsetf ,ref-name ,set-name))))
47 | (define-fetchers-and-storers (bitsize)
48 | (loop for i from 0 below 4
49 | for signedp = (logbitp 1 i)
50 | for big-endian-p = (logbitp 0 i)
51 | collect `(define-fetcher ,bitsize ,signedp ,big-endian-p) into forms
52 | collect `(define-storer ,bitsize ,signedp ,big-endian-p) into forms
53 | finally (return `(progn ,@forms)))))
54 | (define-fetchers-and-storers 16)
55 | (define-fetchers-and-storers 24)
56 | (define-fetchers-and-storers 32)
57 | (define-fetchers-and-storers 64))
58 |
59 | #+sbcl (declaim (sb-ext:maybe-inline ieee-single-ref/be))
60 | (defun ieee-single-ref/be (vector index)
61 | #+abcl
62 | (system::make-single-float (sb32ref/be vector index))
63 | #+allegro
64 | (let ((high (ub16ref/be vector index))
65 | (low (ub16ref/be vector (+ index 2))))
66 | (excl:shorts-to-single-float high low))
67 | #+ccl
68 | (ccl::host-single-float-from-unsigned-byte-32 (ub32ref/be vector index))
69 | #+clasp
70 | (ext:bits-to-single-float (ub32ref/be vector index))
71 | #+clisp
72 | (ffi:with-foreign-object (u '(ffi:c-union (value ffi:single-float) (bits ffi:uint32)))
73 | (setf (ffi:slot (ffi:foreign-value u) 'bits) (ub32ref/be vector index))
74 | (ffi:slot (ffi:foreign-value u) 'value))
75 | #+cmu
76 | (kernel:make-single-float (sb32ref/be vector index))
77 | #+ecl
78 | ;; TODO: Remove version check when ECL version 23.9.9 or later is generally available.
79 | (if (>= ext:+ecl-version-number+ 230909)
80 | (system::bits-single-float (ub32ref/be vector index))
81 | (make-single-float (ub32ref/be vector index)))
82 | #+lispworks
83 | (let* ((ub (ub32ref/be vector index))
84 | (v (sys:make-typed-aref-vector 4)))
85 | (declare (optimize (speed 3) (float 0) (safety 0)))
86 | (declare (dynamic-extent v))
87 | (setf (sys:typed-aref '(unsigned-byte 32) v 0) ub)
88 | (sys:typed-aref 'single-float v 0))
89 | #+mezzano
90 | (mezzano.extensions:ieee-binary32-to-single-float (ub32ref/be vector index))
91 | #+sbcl
92 | (sb-kernel:make-single-float (sb32ref/be vector index))
93 | #-(or abcl allegro ccl clasp clisp cmu ecl lispworks mezzano sbcl)
94 | (make-single-float (ub32ref/be vector index)))
95 |
96 | #+sbcl (declaim (sb-ext:maybe-inline ieee-single-sef/be))
97 | (defun ieee-single-set/be (vector index value)
98 | #+abcl
99 | (progn
100 | (setf (sb32ref/be vector index) (system:single-float-bits value))
101 | value)
102 | #+allegro
103 | (multiple-value-bind (high low) (excl:single-float-to-shorts value)
104 | (setf (ub16ref/be vector index) high
105 | (ub16ref/be vector (+ index 2)) low)
106 | value)
107 | #+ccl
108 | (progn
109 | (setf (ub32ref/be vector index) (ccl::single-float-bits value))
110 | value)
111 | #+clasp
112 | (progn
113 | (setf (ub32ref/be vector index) (ext:single-float-to-bits value))
114 | value)
115 | #+clisp
116 | (let ((bits
117 | (ffi:with-foreign-object (u '(ffi:c-union (value ffi:single-float) (bits ffi:uint32)))
118 | (setf (ffi:slot (ffi:foreign-value u) 'value) value)
119 | (ffi:slot (ffi:foreign-value u) 'bits))))
120 | (setf (ub32ref/be vector index) bits)
121 | value)
122 | #+cmu
123 | (progn
124 | (setf (sb32ref/be vector index) (kernel:single-float-bits value))
125 | value)
126 | #+ecl
127 | ;; TODO: Remove version check when ECL version 23.9.9 or later is generally available.
128 | (progn
129 | (setf (ub32ref/be vector index)
130 | (if (>= ext:+ecl-version-number+ 230909)
131 | (system::single-float-bits value)
132 | (single-float-bits value)))
133 | value)
134 | #+lispworks
135 | (let* ((v (sys:make-typed-aref-vector 4)))
136 | (declare (optimize (speed 3) (float 0) (safety 0)))
137 | (declare (dynamic-extent v))
138 | (setf (sys:typed-aref 'single-float v 0) value)
139 | (setf (ub32ref/be vector index) (sys:typed-aref '(unsigned-byte 32) v 0))
140 | value)
141 | #+mezzano
142 | (progn
143 | (setf (ub32ref/be vector index) (mezzano.extensions:single-float-to-ieee-binary32 value))
144 | value)
145 | #+sbcl
146 | (progn
147 | (setf (sb32ref/be vector index) (sb-kernel:single-float-bits value))
148 | value)
149 | #-(or abcl allegro ccl clasp clisp cmu ecl lispworks mezzano sbcl)
150 | (progn
151 | (setf (ub32ref/be vector index) (single-float-bits value))
152 | value))
153 | (defsetf ieee-single-ref/be ieee-single-set/be)
154 |
155 | #+sbcl (declaim (sb-ext:maybe-inline ieee-single-ref/le))
156 | (defun ieee-single-ref/le (vector index)
157 | #+abcl
158 | (system::make-single-float (sb32ref/le vector index))
159 | #+allegro
160 | (let ((low (ub16ref/le vector index))
161 | (high (ub16ref/le vector (+ index 2))))
162 | (excl:shorts-to-single-float high low))
163 | #+ccl
164 | (ccl::host-single-float-from-unsigned-byte-32 (ub32ref/le vector index))
165 | #+clasp
166 | (ext:bits-to-single-float (ub32ref/le vector index))
167 | #+clisp
168 | (ffi:with-foreign-object (u '(ffi:c-union (value ffi:single-float) (bits ffi:uint32)))
169 | (setf (ffi:slot (ffi:foreign-value u) 'bits) (ub32ref/le vector index))
170 | (ffi:slot (ffi:foreign-value u) 'value))
171 | #+cmu
172 | (kernel:make-single-float (sb32ref/le vector index))
173 | #+ecl
174 | ;; TODO: Remove version check when ECL version 23.9.9 or later is generally available.
175 | (if (>= ext:+ecl-version-number+ 230909)
176 | (system::bits-single-float (ub32ref/le vector index))
177 | (make-single-float (ub32ref/le vector index)))
178 | #+lispworks
179 | (let* ((ub (ub32ref/le vector index))
180 | (v (sys:make-typed-aref-vector 4)))
181 | (declare (optimize (speed 3) (float 0) (safety 0)))
182 | (declare (dynamic-extent v))
183 | (setf (sys:typed-aref '(unsigned-byte 32) v 0) ub)
184 | (sys:typed-aref 'single-float v 0))
185 | #+mezzano
186 | (mezzano.extensions:ieee-binary32-to-single-float (ub32ref/le vector index))
187 | #+sbcl
188 | (sb-kernel:make-single-float (sb32ref/le vector index))
189 | #-(or abcl allegro ccl clasp clisp cmu ecl lispworks mezzano sbcl)
190 | (make-single-float (ub32ref/le vector index))
191 | )
192 |
193 | #+sbcl (declaim (sb-ext:maybe-inline ieee-single-set/le))
194 | (defun ieee-single-set/le (vector index value)
195 | #+abcl
196 | (progn
197 | (setf (sb32ref/le vector index) (system:single-float-bits value))
198 | value)
199 | #+allegro
200 | (multiple-value-bind (high low) (excl:single-float-to-shorts value)
201 | (setf (ub16ref/le vector index) low
202 | (ub16ref/le vector (+ index 2)) high)
203 | value)
204 | #+ccl
205 | (progn
206 | (setf (ub32ref/le vector index) (ccl::single-float-bits value))
207 | value)
208 | #+clasp
209 | (progn
210 | (setf (ub32ref/le vector index) (ext:single-float-to-bits value))
211 | value)
212 | #+clisp
213 | (let ((bits
214 | (ffi:with-foreign-object (u '(ffi:c-union (value ffi:single-float) (bits ffi:uint32)))
215 | (setf (ffi:slot (ffi:foreign-value u) 'value) value)
216 | (ffi:slot (ffi:foreign-value u) 'bits))))
217 | (setf (ub32ref/le vector index) bits)
218 | value)
219 | #+cmu
220 | (progn
221 | (setf (sb32ref/le vector index) (kernel:single-float-bits value))
222 | value)
223 | #+ecl
224 | ;; TODO: Remove version check when ECL version 23.9.9 or later is generally available.
225 | (progn
226 | (setf (ub32ref/le vector index)
227 | (if (>= ext:+ecl-version-number+ 230909)
228 | (system::single-float-bits value)
229 | (single-float-bits value)))
230 | value)
231 | #+lispworks
232 | (let* ((v (sys:make-typed-aref-vector 4)))
233 | (declare (optimize (speed 3) (float 0) (safety 0)))
234 | (declare (dynamic-extent v))
235 | (setf (sys:typed-aref 'single-float v 0) value)
236 | (setf (ub32ref/le vector index) (sys:typed-aref '(unsigned-byte 32) v 0))
237 | value)
238 | #+mezzano
239 | (progn
240 | (setf (ub32ref/le vector index) (mezzano.extensions:single-float-to-ieee-binary32 value))
241 | value)
242 | #+sbcl
243 | (progn
244 | (setf (sb32ref/le vector index) (sb-kernel:single-float-bits value))
245 | value)
246 | #-(or abcl allegro ccl clasp clisp cmu ecl lispworks mezzano sbcl)
247 | (progn
248 | (setf (ub32ref/le vector index) (single-float-bits value))
249 | value))
250 | (defsetf ieee-single-ref/le ieee-single-set/le)
251 |
252 | #+sbcl (declaim (sb-ext:maybe-inline ieee-double-ref/be))
253 | (defun ieee-double-ref/be (vector index)
254 | #+abcl
255 | (let ((upper (sb32ref/be vector index))
256 | (lower (ub32ref/be vector (+ index 4))))
257 | (system:make-double-float (logior (ash upper 32) lower)))
258 | #+allegro
259 | (let ((u3 (ub16ref/be vector index))
260 | (u2 (ub16ref/be vector (+ index 2)))
261 | (u1 (ub16ref/be vector (+ index 4)))
262 | (u0 (ub16ref/be vector (+ index 6))))
263 | (excl:shorts-to-double-float u3 u2 u1 u0))
264 | #+ccl
265 | (let ((upper (ub32ref/be vector index))
266 | (lower (ub32ref/be vector (+ index 4))))
267 | (ccl::double-float-from-bits upper lower))
268 | #+clasp
269 | (let ((upper (ub32ref/be vector index))
270 | (lower (ub32ref/be vector (+ index 4))))
271 | (ext:bits-to-double-float (logior (ash upper 32) lower)))
272 | #+clisp
273 | (let ((upper (ub32ref/be vector index))
274 | (lower (ub32ref/be vector (+ index 4))))
275 | (ffi:with-foreign-object (u '(ffi:c-union (value ffi:double-float) (bits ffi:uint64)))
276 | (setf (ffi:slot (ffi:foreign-value u) 'bits) (logior (ash upper 32) lower))
277 | (ffi:slot (ffi:foreign-value u) 'value)))
278 | #+cmu
279 | (let ((upper (sb32ref/be vector index))
280 | (lower (ub32ref/be vector (+ index 4))))
281 | (kernel:make-double-float upper lower))
282 | #+ecl
283 | ;; TODO: Remove version check when ECL version 23.9.9 or later is generally available.
284 | (let ((upper (ub32ref/be vector index))
285 | (lower (ub32ref/be vector (+ index 4))))
286 | (if (>= ext:+ecl-version-number+ 230909)
287 | (system::bits-double-float (logior (ash upper 32) lower))
288 | (make-double-float upper lower)))
289 | #+lispworks
290 | (let* ((upper (ub32ref/be vector index))
291 | (lower (ub32ref/be vector (+ index 4)))
292 | (v (sys:make-typed-aref-vector 8)))
293 | (declare (optimize (speed 3) (float 0) (safety 0)))
294 | (declare (dynamic-extent v))
295 | #+little-endian
296 | (progn
297 | (setf (sys:typed-aref '(unsigned-byte 32) v 0) lower)
298 | (setf (sys:typed-aref '(unsigned-byte 32) v 4) upper))
299 | #-little-endian
300 | (progn
301 | (setf (sys:typed-aref '(unsigned-byte 32) v 0) upper)
302 | (setf (sys:typed-aref '(unsigned-byte 32) v 4) lower))
303 | (sys:typed-aref 'double-float v 0))
304 | #+mezzano
305 | (let ((upper (ub32ref/be vector index))
306 | (lower (ub32ref/be vector (+ index 4))))
307 | (mezzano.extensions:ieee-binary64-to-double-float (logior (ash upper 32) lower)))
308 | #+sbcl
309 | (let ((upper (sb32ref/be vector index))
310 | (lower (ub32ref/be vector (+ index 4))))
311 | (sb-kernel:make-double-float upper lower))
312 | #-(or abcl allegro ccl clasp clisp cmu ecl lispworks mezzano sbcl)
313 | (let ((upper (ub32ref/be vector index))
314 | (lower (ub32ref/be vector (+ index 4))))
315 | (make-double-float upper lower)))
316 |
317 | #+sbcl (declaim (sb-ext:maybe-inline ieee-double-set/be))
318 | (defun ieee-double-set/be (vector index value)
319 | #+abcl
320 | (progn
321 | (setf (ub32ref/be vector index) (system::double-float-high-bits value)
322 | (ub32ref/be vector (+ index 4)) (system::double-float-low-bits value))
323 | value)
324 | #+allegro
325 | (multiple-value-bind (us3 us2 us1 us0) (excl:double-float-to-shorts value)
326 | (setf (ub16ref/be vector index) us3
327 | (ub16ref/be vector (+ index 2)) us2
328 | (ub16ref/be vector (+ index 4)) us1
329 | (ub16ref/be vector (+ index 6)) us0)
330 | value)
331 | #+ccl
332 | (multiple-value-bind (upper lower) (ccl::double-float-bits value)
333 | (setf (ub32ref/be vector index) upper
334 | (ub32ref/be vector (+ index 4)) lower)
335 | value)
336 | #+clasp
337 | (let ((bits (ext:double-float-to-bits value)))
338 | (setf (ub32ref/be vector index) (ldb (byte 32 32) bits)
339 | (ub32ref/be vector (+ index 4)) (ldb (byte 32 0) bits))
340 | value)
341 | #+clisp
342 | (let ((bits
343 | (ffi:with-foreign-object (u '(ffi:c-union (value ffi:double-float) (bits ffi:uint64)))
344 | (setf (ffi:slot (ffi:foreign-value u) 'value) value)
345 | (ffi:slot (ffi:foreign-value u) 'bits))))
346 | (setf (ub32ref/be vector index) (ldb (byte 32 32) bits)
347 | (ub32ref/be vector (+ index 4)) (ldb (byte 32 0) bits))
348 | value)
349 | #+cmu
350 | (progn
351 | (setf (sb32ref/be vector index) (kernel:double-float-high-bits value)
352 | (ub32ref/be vector (+ index 4)) (kernel:double-float-low-bits value))
353 | value)
354 | #+ecl
355 | ;; TODO: Remove version check when ECL version 23.9.9 or later is generally available.
356 | (if (>= ext:+ecl-version-number+ 230909)
357 | (let ((bits (system::double-float-bits value)))
358 | (setf (ub32ref/be vector index) (ldb (byte 32 32) bits)
359 | (ub32ref/be vector (+ index 4)) (ldb (byte 32 0) bits))
360 | value)
361 | (multiple-value-bind (upper lower) (double-float-bits value)
362 | (setf (ub32ref/be vector index) upper
363 | (ub32ref/be vector (+ index 4)) lower)
364 | value))
365 | #+lispworks
366 | (let* ((v (sys:make-typed-aref-vector 8)))
367 | (declare (optimize (speed 3) (float 0) (safety 0)))
368 | (declare (dynamic-extent v))
369 | (setf (sys:typed-aref 'double-float v 0) value)
370 | #+little-endian
371 | (progn
372 | (setf (ub32ref/be vector index) (sys:typed-aref '(unsigned-byte 32) v 4)
373 | (ub32ref/be vector (+ index 4)) (sys:typed-aref '(unsigned-byte 32) v 0)))
374 | #-little-endian
375 | (progn
376 | (setf (ub32ref/be vector index) (sys:typed-aref '(unsigned-byte 32) v 0)
377 | (ub32ref/be vector (+ index 4)) (sys:typed-aref '(unsigned-byte 32) v 4)))
378 | value)
379 | #+mezzano
380 | (let ((bits (mezzano.extensions:double-float-to-ieee-binary64 value)))
381 | (setf (ub32ref/be vector index) (ldb (byte 32 32) bits)
382 | (ub32ref/be vector (+ index 4)) (ldb (byte 32 0) bits))
383 | value)
384 | #+sbcl
385 | (progn
386 | (setf (sb32ref/be vector index) (sb-kernel:double-float-high-bits value)
387 | (ub32ref/be vector (+ index 4)) (sb-kernel:double-float-low-bits value))
388 | value)
389 | #-(or abcl allegro ccl clasp clisp cmu ecl lispworks mezzano sbcl)
390 | (multiple-value-bind (upper lower) (double-float-bits value)
391 | (setf (ub32ref/be vector index) upper
392 | (ub32ref/be vector (+ index 4)) lower)
393 | value))
394 | (defsetf ieee-double-ref/be ieee-double-set/be)
395 |
396 | #+sbcl (declaim (sb-ext:maybe-inline ieee-double-ref/le))
397 | (defun ieee-double-ref/le (vector index)
398 | #+abcl
399 | (let ((lower (ub32ref/le vector index))
400 | (upper (sb32ref/le vector (+ index 4))))
401 | (system:make-double-float (logior (ash upper 32) lower)))
402 | #+allegro
403 | (let ((u0 (ub16ref/le vector index))
404 | (u1 (ub16ref/le vector (+ index 2)))
405 | (u2 (ub16ref/le vector (+ index 4)))
406 | (u3 (ub16ref/le vector (+ index 6))))
407 | (excl:shorts-to-double-float u3 u2 u1 u0))
408 | #+ccl
409 | (let ((lower (ub32ref/le vector index))
410 | (upper (ub32ref/le vector (+ index 4))))
411 | (ccl::double-float-from-bits upper lower))
412 | #+clasp
413 | (let ((lower (ub32ref/le vector index))
414 | (upper (ub32ref/le vector (+ index 4))))
415 | (ext:bits-to-double-float (logior (ash upper 32) lower)))
416 | #+clisp
417 | (let ((lower (ub32ref/le vector index))
418 | (upper (ub32ref/le vector (+ index 4))))
419 | (ffi:with-foreign-object (u '(ffi:c-union (value ffi:double-float) (bits ffi:uint64)))
420 | (setf (ffi:slot (ffi:foreign-value u) 'bits) (logior (ash upper 32) lower))
421 | (ffi:slot (ffi:foreign-value u) 'value)))
422 | #+cmu
423 | (let ((lower (ub32ref/le vector index))
424 | (upper (sb32ref/le vector (+ index 4))))
425 | (kernel:make-double-float upper lower))
426 | #+ecl
427 | ;; TODO: Remove version check when ECL version 23.9.9 or later is generally available.
428 | (let ((lower (ub32ref/le vector index))
429 | (upper (ub32ref/le vector (+ index 4))))
430 | (if (>= ext:+ecl-version-number+ 230909)
431 | (system::bits-double-float (logior (ash upper 32) lower))
432 | (make-double-float upper lower)))
433 | #+lispworks
434 | (let* ((lower (ub32ref/le vector index))
435 | (upper (ub32ref/le vector (+ index 4)))
436 | (v (sys:make-typed-aref-vector 8)))
437 | (declare (optimize (speed 3) (float 0) (safety 0)))
438 | (declare (dynamic-extent v))
439 | #+little-endian
440 | (progn
441 | (setf (sys:typed-aref '(unsigned-byte 32) v 0) lower)
442 | (setf (sys:typed-aref '(unsigned-byte 32) v 4) upper))
443 | #-little-endian
444 | (progn
445 | (setf (sys:typed-aref '(unsigned-byte 32) v 0) upper)
446 | (setf (sys:typed-aref '(unsigned-byte 32) v 4) lower))
447 | (sys:typed-aref 'double-float v 0))
448 | #+mezzano
449 | (let ((lower (ub32ref/le vector index))
450 | (upper (ub32ref/le vector (+ index 4))))
451 | (mezzano.extensions:ieee-binary64-to-double-float (logior (ash upper 32) lower)))
452 | #+sbcl
453 | (let ((lower (ub32ref/le vector index))
454 | (upper (sb32ref/le vector (+ index 4))))
455 | (sb-kernel:make-double-float upper lower))
456 | #-(or abcl allegro ccl clasp clisp cmu ecl lispworks mezzano sbcl)
457 | (let ((lower (ub32ref/le vector index))
458 | (upper (ub32ref/le vector (+ index 4))))
459 | (make-double-float upper lower)))
460 |
461 | #+sbcl (declaim (sb-ext:maybe-inline ieee-double-set/le))
462 | (defun ieee-double-set/le (vector index value)
463 | #+abcl
464 | (progn
465 | (setf (ub32ref/le vector index) (system::double-float-low-bits value)
466 | (ub32ref/le vector (+ index 4)) (system::double-float-high-bits value))
467 | value)
468 | #+allegro
469 | (multiple-value-bind (us3 us2 us1 us0) (excl:double-float-to-shorts value)
470 | (setf (ub16ref/le vector index) us0
471 | (ub16ref/le vector (+ index 2)) us1
472 | (ub16ref/le vector (+ index 4)) us2
473 | (ub16ref/le vector (+ index 6)) us3)
474 | value)
475 | #+ccl
476 | (multiple-value-bind (upper lower) (ccl::double-float-bits value)
477 | (setf (ub32ref/le vector index) lower
478 | (ub32ref/le vector (+ index 4)) upper)
479 | value)
480 | #+clasp
481 | (let ((bits (ext:double-float-to-bits value)))
482 | (setf (ub32ref/le vector index) (ldb (byte 32 0) bits)
483 | (ub32ref/le vector (+ index 4)) (ldb (byte 32 32) bits))
484 | value)
485 | #+clisp
486 | (let ((bits
487 | (ffi:with-foreign-object (u '(ffi:c-union (value ffi:double-float) (bits ffi:uint64)))
488 | (setf (ffi:slot (ffi:foreign-value u) 'value) value)
489 | (ffi:slot (ffi:foreign-value u) 'bits))))
490 | (setf (ub32ref/le vector index) (ldb (byte 32 0) bits)
491 | (ub32ref/le vector (+ index 4)) (ldb (byte 32 32) bits))
492 | value)
493 | #+cmu
494 | (progn
495 | (setf (ub32ref/le vector index) (kernel:double-float-low-bits value)
496 | (sb32ref/le vector (+ index 4)) (kernel:double-float-high-bits value))
497 | value)
498 | #+ecl
499 | ;; TODO: Remove version check when ECL version 23.9.9 or later is generally available.
500 | (if (>= ext:+ecl-version-number+ 230909)
501 | (let ((bits (system::double-float-bits value)))
502 | (setf (ub32ref/le vector index) (ldb (byte 32 0) bits)
503 | (ub32ref/le vector (+ index 4)) (ldb (byte 32 32) bits))
504 | value)
505 | (multiple-value-bind (upper lower) (double-float-bits value)
506 | (setf (ub32ref/le vector index) lower
507 | (ub32ref/le vector (+ index 4)) upper)
508 | value))
509 | #+lispworks
510 | (let* ((v (sys:make-typed-aref-vector 8)))
511 | (declare (optimize (speed 3) (float 0) (safety 0)))
512 | (declare (dynamic-extent v))
513 | (setf (sys:typed-aref 'double-float v 0) value)
514 | #+little-endian
515 | (progn
516 | (setf (ub32ref/le vector index) (sys:typed-aref '(unsigned-byte 32) v 0)
517 | (ub32ref/le vector (+ index 4)) (sys:typed-aref '(unsigned-byte 32) v 4)))
518 | #-little-endian
519 | (progn
520 | (setf (ub32ref/le vector index) (sys:typed-aref '(unsigned-byte 32) v 4)
521 | (ub32ref/le vector (+ index 4)) (sys:typed-aref '(unsigned-byte 32) v 0)))
522 | value)
523 | #+mezzano
524 | (let ((bits (mezzano.extensions:double-float-to-ieee-binary64 value)))
525 | (setf (ub32ref/le vector index) (ldb (byte 32 0) bits)
526 | (ub32ref/le vector (+ index 4)) (ldb (byte 32 32) bits))
527 | value)
528 | #+sbcl
529 | (progn
530 | (setf (ub32ref/le vector index) (sb-kernel:double-float-low-bits value)
531 | (sb32ref/le vector (+ index 4)) (sb-kernel:double-float-high-bits value))
532 | value)
533 | #-(or abcl allegro ccl clasp clisp cmu ecl lispworks mezzano sbcl)
534 | (multiple-value-bind (upper lower) (double-float-bits value)
535 | (setf (ub32ref/le vector index) lower
536 | (ub32ref/le vector (+ index 4)) upper)
537 | value))
538 | (defsetf ieee-double-ref/le ieee-double-set/le)
539 |
--------------------------------------------------------------------------------