├── .gitignore ├── .travis.yml ├── LICENSE ├── NEWS ├── README ├── doc ├── index.html ├── nibbles-doc.txt └── style.css ├── macro-utils.lisp ├── nibbles.asd ├── package.lisp ├── rt.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 | language: common-lisp 2 | sudo: required 3 | 4 | env: 5 | matrix: 6 | - LISP=sbcl 7 | - LISP=ccl 8 | - LISP=clisp 9 | - LISP=abcl 10 | - LISP=allegro 11 | 12 | install: 13 | # Install cl-travis 14 | - curl https://raw.githubusercontent.com/luismbo/cl-travis/master/install.sh | bash 15 | 16 | script: 17 | - cl -l nibbles -l nibbles-tests 18 | -e '(setf *debugger-hook* 19 | (lambda (&rest ignorable) 20 | (declare (ignore ignorable)) 21 | (uiop:quit -1)))' 22 | -e '(rt:do-tests)' 23 | -------------------------------------------------------------------------------- /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: -------------------------------------------------------------------------------- 1 | When dealing with network protocols and file formats, it's common to 2 | have to read or write 16-, 32-, or 64-bit datatypes in signed or 3 | unsigned flavors. Common Lisp sort of supports this by specifying 4 | :ELEMENT-TYPE for streams, but that facility is underspecified and 5 | there's nothing similar for read/write from octet vectors. What most 6 | people wind up doing is rolling their own small facility for their 7 | particular needs and calling it a day. 8 | 9 | This library attempts to be comprehensive and centralize such 10 | facilities. Functions to read 16-, 32-, and 64-bit quantities from 11 | octet vectors in signed or unsigned flavors are provided; these 12 | functions are also SETFable. Since it's sometimes desirable to 13 | read/write directly from streams, functions for doing so are also 14 | provided. On some implementations, reading/writing IEEE singles/doubles 15 | (i.e. SINGLE-FLOAT and DOUBLE-FLOAT) will also be supported. 16 | 17 | In addition to centralizing such facilities, NIBBLES also aspires to 18 | become a place where compiler optimizations can be written once and used 19 | everywhere. The intention is that (eventually): 20 | 21 | (nibbles:sb32ref/le vector index) 22 | 23 | will compile (with any necessary safety checks) to a MOVSX instruction 24 | on an x86oid processor in SBCL (or other implementations) if VECTOR and 25 | INDEX are of appropriate types. 26 | 27 | I remember reading a post on comp.lang.lisp that suggested the designers 28 | of Common Lisp ignored the realities of octets and endianness and so 29 | forth. This library is a small step towards remedying that deficiency. 30 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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.13" 24 | :author "Nathan Froyd " 25 | :maintainer "Nathan Froyd " 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") 30 | (:static-file "LICENSE") 31 | (:static-file "NEWS") 32 | (:file "package") 33 | (:file "types" :depends-on ("package")) 34 | (:file "macro-utils" :depends-on ("package")) 35 | (:file "vectors" :depends-on ("types" "macro-utils")) 36 | (:file "streams" :depends-on ("vectors")) 37 | (:module "doc" 38 | :components 39 | ((:html-file "index") 40 | (:txt-file "nibbles-doc") 41 | (:css-file "style"))) 42 | (:module "sbcl-opt" 43 | :depends-on ("package" "macro-utils") 44 | :components ((:file "fndb") 45 | (:file "nib-tran" :depends-on ("fndb")) 46 | (:file "x86-vm" :depends-on ("fndb")) 47 | (:file "x86-64-vm" :depends-on ("fndb")))))) 48 | 49 | (defmethod asdf:perform ((op asdf:test-op) 50 | (c (eql (asdf:find-system :nibbles)))) 51 | (asdf:oos 'asdf:test-op 'nibbles-tests)) 52 | 53 | (asdf:defsystem :nibbles-tests 54 | :depends-on (:nibbles) 55 | :version "0.1" 56 | :author "Nathan Froyd " 57 | :maintainer "Nathan Froyd " 58 | :in-order-to ((asdf:test-op (asdf:load-op :nibbles-tests))) 59 | :components ((:file "rt") 60 | (:file "tests" :depends-on ("rt")))) 61 | 62 | (defmethod asdf:perform ((op asdf:test-op) 63 | (c (eql (asdf:find-system :nibbles-tests)))) 64 | (or (funcall (intern (symbol-name :do-tests) (find-package :rtest))) 65 | (error "TEST-OP failed for NIBBLES-TESTS"))) 66 | -------------------------------------------------------------------------------- /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 | #:ub32ref/le #:ub32ref/be #:sb32ref/le #:sb32ref/be 10 | #:ub64ref/le #:ub64ref/be #:sb64ref/le #:sb64ref/be) 11 | ;; Stream readers. 12 | (:export #:read-ub16/le #:read-ub16/be #:read-sb16/be #:read-sb16/le 13 | #:read-ub32/le #:read-ub32/be #:read-sb32/be #:read-sb32/le 14 | #:read-ub64/le #:read-ub64/be #:read-sb64/be #:read-sb64/le) 15 | ;; Stream readers for vectors. 16 | (:export #:read-ub16/le-sequence #:read-ub16/be-sequence 17 | #:read-sb16/le-sequence #:read-sb16/be-sequence 18 | #:read-ub32/le-sequence #:read-ub32/be-sequence 19 | #:read-sb32/le-sequence #:read-sb32/be-sequence 20 | #:read-ub64/le-sequence #:read-ub64/be-sequence 21 | #:read-sb64/le-sequence #:read-sb64/be-sequence) 22 | ;; Non-consing variants akin to READ-SEQUENCE. 23 | (:export #:read-ub16/le-into-sequence #:read-ub16/be-into-sequence 24 | #:read-sb16/le-into-sequence #:read-sb16/be-into-sequence 25 | #:read-ub32/le-into-sequence #:read-ub32/be-into-sequence 26 | #:read-sb32/le-into-sequence #:read-sb32/be-into-sequence 27 | #:read-ub64/le-into-sequence #:read-ub64/be-into-sequence 28 | #:read-sb64/le-into-sequence #:read-sb64/be-into-sequence) 29 | ;; Stream writers. 30 | (:export #:write-ub16/le #:write-ub16/be #:write-sb16/be #:write-sb16/le 31 | #:write-ub32/le #:write-ub32/be #:write-sb32/be #:write-sb32/le 32 | #:write-ub64/le #:write-ub64/be #:write-sb64/be #:write-sb64/le) 33 | ;; Stream writers for vectors. 34 | (:export #:write-ub16/le-sequence #:write-ub16/be-sequence 35 | #:write-sb16/le-sequence #:write-sb16/be-sequence 36 | #:write-ub32/le-sequence #:write-ub32/be-sequence 37 | #:write-sb32/le-sequence #:write-sb32/be-sequence 38 | #:write-ub64/le-sequence #:write-ub64/be-sequence 39 | #:write-sb64/le-sequence #:write-sb64/be-sequence) 40 | ;; The following floating-point functions are not supported on all platforms. 41 | ;; Floating-point octet vector accessors. 42 | (:export #:ieee-single-ref/be #:ieee-single-ref/le 43 | #:ieee-double-ref/be #:ieee-double-ref/le) 44 | ;; Floating-point stream readers. 45 | (:export #:read-ieee-single/be #:read-ieee-single/le 46 | #:read-ieee-double/be #:read-ieee-double/le) 47 | ;; Stream readers for floating-point sequences. 48 | (:export #:read-ieee-single/be-sequence #:read-ieee-single/le-sequence 49 | #:read-ieee-double/be-sequence #:read-ieee-double/le-sequence) 50 | ;; Non-consing variants akin to READ-SEQUENCE. 51 | (:export #:read-ieee-single/be-into-sequence #:read-ieee-single/le-into-sequence 52 | #:read-ieee-double/be-into-sequence #:read-ieee-double/le-into-sequence) 53 | ;; Stream writers. 54 | (:export #:write-ieee-single/be #:write-ieee-single/le 55 | #:write-ieee-double/be #:write-ieee-double/le) 56 | ;; Stream writers for sequences. 57 | (:export #:write-ieee-single/be-sequence #:write-ieee-single/le-sequence 58 | #:write-ieee-double/be-sequence #:write-ieee-double/le-sequence)) 59 | -------------------------------------------------------------------------------- /rt.lisp: -------------------------------------------------------------------------------- 1 | ;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*- 2 | 3 | #|----------------------------------------------------------------------------| 4 | | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | 5 | | | 6 | | Permission to use, copy, modify, and distribute this software and its | 7 | | documentation for any purpose and without fee is hereby granted, provided | 8 | | that this copyright and permission notice appear in all copies and | 9 | | supporting documentation, and that the name of M.I.T. not be used in | 10 | | advertising or publicity pertaining to distribution of the software | 11 | | without specific, written prior permission. M.I.T. makes no | 12 | | representations about the suitability of this software for any purpose. | 13 | | It is provided "as is" without express or implied warranty. | 14 | | | 15 | | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | 16 | | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | 17 | | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | 18 | | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | 19 | | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | 20 | | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | 21 | | SOFTWARE. | 22 | |----------------------------------------------------------------------------|# 23 | 24 | (defpackage #:regression-test 25 | (:nicknames #:rtest #-lispworks #:rt) 26 | (:use #:cl) 27 | (:export #:*do-tests-when-defined* #:*test* #:continue-testing 28 | #:deftest #:do-test #:do-tests #:get-test #:pending-tests 29 | #:rem-all-tests #:rem-test) 30 | (:documentation "The MIT regression tester with pfdietz's modifications")) 31 | 32 | ;;This was the December 19, 1990 version of the regression tester, but 33 | ;;has since been modified. 34 | 35 | (in-package :regression-test) 36 | 37 | (declaim (ftype (function (t) t) get-entry expanded-eval do-entries)) 38 | (declaim (type list *entries*)) 39 | (declaim (ftype (function (t &rest t) t) report-error)) 40 | (declaim (ftype (function (t &optional t) t) do-entry)) 41 | 42 | (defvar *test* nil "Current test name") 43 | (defvar *do-tests-when-defined* nil) 44 | (defvar *entries* '(nil) "Test database. Has a leading dummy cell that does not contain an entry.") 45 | (defvar *entries-tail* *entries* "Tail of the *entries* list") 46 | (defvar *entries-table* (make-hash-table :test #'equal) 47 | "Map the names of entries to the cons cell in *entries* that precedes the one whose car is the entry.") 48 | (defvar *in-test* nil "Used by TEST") 49 | (defvar *debug* nil "For debugging") 50 | (defvar *catch-errors* t "When true, causes errors in a test to be caught.") 51 | (defvar *print-circle-on-failure* nil 52 | "Failure reports are printed with *PRINT-CIRCLE* bound to this value.") 53 | 54 | (defvar *compile-tests* nil "When true, compile the tests before running them.") 55 | (defvar *expanded-eval* nil "When true, convert the tests into a form that is less likely to have compiler optimizations.") 56 | (defvar *optimization-settings* '((safety 3))) 57 | 58 | (defvar *expected-failures* nil 59 | "A list of test names that are expected to fail.") 60 | 61 | (defvar *notes* (make-hash-table :test 'equal) 62 | "A mapping from names of notes to note objects.") 63 | 64 | (defstruct (entry (:conc-name nil)) 65 | pend name props form vals) 66 | 67 | ;;; Note objects are used to attach information to tests. 68 | ;;; A typical use is to mark tests that depend on a particular 69 | ;;; part of a set of requirements, or a particular interpretation 70 | ;;; of the requirements. 71 | 72 | (defstruct note 73 | name 74 | contents 75 | disabled ;; When true, tests with this note are considered inactive 76 | ) 77 | 78 | ;; (defmacro vals (entry) `(cdddr ,entry)) 79 | 80 | (defmacro defn (entry) 81 | (let ((var (gensym))) 82 | `(let ((,var ,entry)) 83 | (list* (name ,var) (form ,var) (vals ,var))))) 84 | 85 | (defun entry-notes (entry) 86 | (let* ((props (props entry)) 87 | (notes (getf props :notes))) 88 | (if (listp notes) 89 | notes 90 | (list notes)))) 91 | 92 | (defun has-disabled-note (entry) 93 | (let ((notes (entry-notes entry))) 94 | (loop for n in notes 95 | for note = (if (note-p n) n 96 | (gethash n *notes*)) 97 | thereis (and note (note-disabled note))))) 98 | 99 | (defun pending-tests () 100 | (loop for entry in (cdr *entries*) 101 | when (and (pend entry) (not (has-disabled-note entry))) 102 | collect (name entry))) 103 | 104 | (defun rem-all-tests () 105 | (setq *entries* (list nil)) 106 | (setq *entries-tail* *entries*) 107 | (clrhash *entries-table*) 108 | nil) 109 | 110 | (defun rem-test (&optional (name *test*)) 111 | (let ((pred (gethash name *entries-table*))) 112 | (when pred 113 | (if (null (cddr pred)) 114 | (setq *entries-tail* pred) 115 | (setf (gethash (name (caddr pred)) *entries-table*) pred)) 116 | (setf (cdr pred) (cddr pred)) 117 | (remhash name *entries-table*) 118 | name))) 119 | 120 | (defun get-test (&optional (name *test*)) 121 | (defn (get-entry name))) 122 | 123 | (defun get-entry (name) 124 | (let ((entry ;; (find name (the list (cdr *entries*)) 125 | ;; :key #'name :test #'equal) 126 | (cadr (gethash name *entries-table*)) 127 | )) 128 | (when (null entry) 129 | (report-error t 130 | "~%No test with name ~:@(~S~)." 131 | name)) 132 | entry)) 133 | 134 | (defmacro deftest (name &rest body) 135 | (let* ((p body) 136 | (properties 137 | (loop while (keywordp (first p)) 138 | unless (cadr p) 139 | do (error "Poorly formed deftest: ~A~%" 140 | (list* 'deftest name body)) 141 | append (list (pop p) (pop p)))) 142 | (form (pop p)) 143 | (vals p)) 144 | `(add-entry (make-entry :pend t 145 | :name ',name 146 | :props ',properties 147 | :form ',form 148 | :vals ',vals)))) 149 | 150 | (defun add-entry (entry) 151 | (setq entry (copy-entry entry)) 152 | (let* ((pred (gethash (name entry) *entries-table*))) 153 | (cond 154 | (pred 155 | (setf (cadr pred) entry) 156 | (report-error nil 157 | "Redefining test ~:@(~S~)" 158 | (name entry))) 159 | (t 160 | (setf (gethash (name entry) *entries-table*) *entries-tail*) 161 | (setf (cdr *entries-tail*) (cons entry nil)) 162 | (setf *entries-tail* (cdr *entries-tail*)) 163 | ))) 164 | (when *do-tests-when-defined* 165 | (do-entry entry)) 166 | (setq *test* (name entry))) 167 | 168 | (defun report-error (error? &rest args) 169 | (cond (*debug* 170 | (apply #'format t args) 171 | (if error? (throw '*debug* nil))) 172 | (error? (apply #'error args)) 173 | (t (apply #'warn args))) 174 | nil) 175 | 176 | (defun do-test (&optional (name *test*)) 177 | #-sbcl (do-entry (get-entry name)) 178 | #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning)) 179 | (do-entry (get-entry name)))) 180 | 181 | (defun my-aref (a &rest args) 182 | (apply #'aref a args)) 183 | 184 | (defun my-row-major-aref (a index) 185 | (row-major-aref a index)) 186 | 187 | (defun equalp-with-case (x y) 188 | "Like EQUALP, but doesn't do case conversion of characters. 189 | Currently doesn't work on arrays of dimension > 2." 190 | (cond 191 | ((eq x y) t) 192 | ((consp x) 193 | (and (consp y) 194 | (equalp-with-case (car x) (car y)) 195 | (equalp-with-case (cdr x) (cdr y)))) 196 | ((and (typep x 'array) 197 | (= (array-rank x) 0)) 198 | (equalp-with-case (my-aref x) (my-aref y))) 199 | ((typep x 'vector) 200 | (and (typep y 'vector) 201 | (let ((x-len (length x)) 202 | (y-len (length y))) 203 | (and (eql x-len y-len) 204 | (loop 205 | for i from 0 below x-len 206 | for e1 = (my-aref x i) 207 | for e2 = (my-aref y i) 208 | always (equalp-with-case e1 e2)))))) 209 | ((and (typep x 'array) 210 | (typep y 'array) 211 | (not (equal (array-dimensions x) 212 | (array-dimensions y)))) 213 | nil) 214 | 215 | ((typep x 'array) 216 | (and (typep y 'array) 217 | (let ((size (array-total-size x))) 218 | (loop for i from 0 below size 219 | always (equalp-with-case (my-row-major-aref x i) 220 | (my-row-major-aref y i)))))) 221 | 222 | (t (eql x y)))) 223 | 224 | (defun do-entry (entry &optional 225 | (s *standard-output*)) 226 | (catch '*in-test* 227 | (setq *test* (name entry)) 228 | (setf (pend entry) t) 229 | (let* ((*in-test* t) 230 | ;; (*break-on-warnings* t) 231 | (aborted nil) 232 | r) 233 | ;; (declare (special *break-on-warnings*)) 234 | 235 | (block aborted 236 | (setf r 237 | (flet ((%do 238 | () 239 | (cond 240 | (*compile-tests* 241 | (multiple-value-list 242 | (funcall (compile 243 | nil 244 | `(lambda () 245 | (declare 246 | (optimize ,@*optimization-settings*)) 247 | ,(form entry)))))) 248 | (*expanded-eval* 249 | (multiple-value-list 250 | (expanded-eval (form entry)))) 251 | (t 252 | (multiple-value-list 253 | (eval (form entry))))))) 254 | (if *catch-errors* 255 | (handler-bind 256 | (#-ecl (style-warning #'muffle-warning) 257 | (error #'(lambda (c) 258 | (setf aborted t) 259 | (setf r (list c)) 260 | (return-from aborted nil)))) 261 | (%do)) 262 | (%do))))) 263 | 264 | (setf (pend entry) 265 | (or aborted 266 | (not (equalp-with-case r (vals entry))))) 267 | 268 | (when (pend entry) 269 | (let ((*print-circle* *print-circle-on-failure*)) 270 | (format s "~&Test ~:@(~S~) failed~ 271 | ~%Form: ~S~ 272 | ~%Expected value~P: ~ 273 | ~{~S~^~%~17t~}~%" 274 | *test* (form entry) 275 | (length (vals entry)) 276 | (vals entry)) 277 | (handler-case 278 | (let ((st (format nil "Actual value~P: ~ 279 | ~{~S~^~%~15t~}.~%" 280 | (length r) r))) 281 | (format s "~A" st)) 282 | (error () (format s "Actual value: #~%") 283 | )) 284 | (finish-output s) 285 | )))) 286 | (when (not (pend entry)) *test*)) 287 | 288 | (defun expanded-eval (form) 289 | "Split off top level of a form and eval separately. This reduces the chance that 290 | compiler optimizations will fold away runtime computation." 291 | (if (not (consp form)) 292 | (eval form) 293 | (let ((op (car form))) 294 | (cond 295 | ((eq op 'let) 296 | (let* ((bindings (loop for b in (cadr form) 297 | collect (if (consp b) b (list b nil)))) 298 | (vars (mapcar #'car bindings)) 299 | (binding-forms (mapcar #'cadr bindings))) 300 | (apply 301 | (the function 302 | (eval `(lambda ,vars ,@(cddr form)))) 303 | (mapcar #'eval binding-forms)))) 304 | ((and (eq op 'let*) (cadr form)) 305 | (let* ((bindings (loop for b in (cadr form) 306 | collect (if (consp b) b (list b nil)))) 307 | (vars (mapcar #'car bindings)) 308 | (binding-forms (mapcar #'cadr bindings))) 309 | (funcall 310 | (the function 311 | (eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form)))) 312 | (eval (car binding-forms))))) 313 | ((eq op 'progn) 314 | (loop for e on (cdr form) 315 | do (if (null (cdr e)) (return (eval (car e))) 316 | (eval (car e))))) 317 | ((and (symbolp op) (fboundp op) 318 | (not (macro-function op)) 319 | (not (special-operator-p op))) 320 | (apply (symbol-function op) 321 | (mapcar #'eval (cdr form)))) 322 | (t (eval form)))))) 323 | 324 | (defun continue-testing () 325 | (if *in-test* 326 | (throw '*in-test* nil) 327 | (do-entries *standard-output*))) 328 | 329 | (defun do-tests (&optional 330 | (out *standard-output*)) 331 | (dolist (entry (cdr *entries*)) 332 | (setf (pend entry) t)) 333 | (if (streamp out) 334 | (do-entries out) 335 | (with-open-file 336 | (stream out :direction :output) 337 | (do-entries stream)))) 338 | 339 | (defun do-entries* (s) 340 | (format s "~&Doing ~A pending test~:P ~ 341 | of ~A tests total.~%" 342 | (count t (the list (cdr *entries*)) :key #'pend) 343 | (length (cdr *entries*))) 344 | (finish-output s) 345 | (dolist (entry (cdr *entries*)) 346 | (when (and (pend entry) 347 | (not (has-disabled-note entry))) 348 | (format s "~@[~<~%~:; ~:@(~S~)~>~]" 349 | (do-entry entry s)) 350 | (finish-output s) 351 | )) 352 | (let ((pending (pending-tests)) 353 | (expected-table (make-hash-table :test #'equal))) 354 | (dolist (ex *expected-failures*) 355 | (setf (gethash ex expected-table) t)) 356 | (let ((new-failures 357 | (loop for pend in pending 358 | unless (gethash pend expected-table) 359 | collect pend))) 360 | (if (null pending) 361 | (format s "~&No tests failed.") 362 | (progn 363 | (format s "~&~A out of ~A ~ 364 | total tests failed: ~ 365 | ~:@(~{~<~% ~1:;~S~>~ 366 | ~^, ~}~)." 367 | (length pending) 368 | (length (cdr *entries*)) 369 | pending) 370 | (if (null new-failures) 371 | (format s "~&No unexpected failures.") 372 | (when *expected-failures* 373 | (format s "~&~A unexpected failures: ~ 374 | ~:@(~{~<~% ~1:;~S~>~ 375 | ~^, ~}~)." 376 | (length new-failures) 377 | new-failures))) 378 | )) 379 | (finish-output s) 380 | (null pending)))) 381 | 382 | (defun do-entries (s) 383 | #-sbcl (do-entries* s) 384 | #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning)) 385 | (do-entries* s))) 386 | 387 | ;;; Note handling functions and macros 388 | 389 | (defmacro defnote (name contents &optional disabled) 390 | `(eval-when (:load-toplevel :execute) 391 | (let ((note (make-note :name ',name 392 | :contents ',contents 393 | :disabled ',disabled))) 394 | (setf (gethash (note-name note) *notes*) note) 395 | note))) 396 | 397 | (defun disable-note (n) 398 | (let ((note (if (note-p n) n 399 | (setf n (gethash n *notes*))))) 400 | (unless note (error "~A is not a note or note name." n)) 401 | (setf (note-disabled note) t) 402 | note)) 403 | 404 | (defun enable-note (n) 405 | (let ((note (if (note-p n) n 406 | (setf n (gethash n *notes*))))) 407 | (unless note (error "~A is not a note or note name." n)) 408 | (setf (note-disabled note) nil) 409 | note)) 410 | -------------------------------------------------------------------------------- /sbcl-opt/fndb.lisp: -------------------------------------------------------------------------------- 1 | ;;;; fndb.lisp -- DEFKNOWNish bits for SBCL 2 | 3 | (cl:in-package :nibbles) 4 | 5 | #+sbcl (progn 6 | 7 | ;;; Efficient array bounds checking 8 | (sb-c:defknown %check-bound 9 | ((simple-array (unsigned-byte 8) (*)) index (and fixnum sb-vm:word) 10 | (member 2 4 8 16)) 11 | index (sb-c:any) :overwrite-fndb-silently t) 12 | 13 | ;; We DEFKNOWN the exported functions so we can DEFTRANSFORM them. 14 | ;; We DEFKNOWN the %-functions so we can DEFINE-VOP them. 15 | 16 | #.(loop for i from 0 to #-x86-64 #b0111 #+x86-64 #b1011 17 | for bitsize = (ecase (ldb (byte 2 2) i) 18 | (0 16) 19 | (1 32) 20 | (2 64)) 21 | for signedp = (logbitp 1 i) 22 | for setterp = (logbitp 0 i) 23 | for byte-fun = (if setterp 24 | #'byte-set-fun-name 25 | #'byte-ref-fun-name) 26 | for big-fun = (funcall byte-fun bitsize signedp t) 27 | for little-fun = (funcall byte-fun bitsize signedp nil) 28 | for internal-big = (internalify big-fun) 29 | for internal-little = (internalify little-fun) 30 | for arg-type = `(,(if signedp 31 | 'signed-byte 32 | 'unsigned-byte) 33 | ,bitsize) 34 | for external-arg-types = `(array index ,@(when setterp 35 | `(,arg-type))) 36 | for internal-arg-types = (subst '(simple-array (unsigned-byte 8)) 'array 37 | external-arg-types) 38 | collect `(sb-c:defknown (,big-fun ,little-fun) ,external-arg-types 39 | ,arg-type (sb-c:any) :overwrite-fndb-silently t) into defknowns 40 | collect `(sb-c:defknown (,internal-big ,internal-little) 41 | ,internal-arg-types 42 | ,arg-type (sb-c:any) :overwrite-fndb-silently t) into defknowns 43 | finally (return `(progn ,@defknowns))) 44 | 45 | );#+sbcl 46 | -------------------------------------------------------------------------------- /sbcl-opt/nib-tran.lisp: -------------------------------------------------------------------------------- 1 | ;;;; nib-tran.lisp -- DEFTRANSFORMs for SBCL 2 | 3 | (cl:in-package :nibbles) 4 | 5 | #+sbcl (progn 6 | 7 | (sb-c:deftransform %check-bound ((vector bound offset n-bytes) 8 | ((simple-array (unsigned-byte 8) (*)) index 9 | (and fixnum sb-vm:word) 10 | (member 2 4 8 16)) 11 | * :node node) 12 | "optimize away bounds check" 13 | ;; cf. sb-c::%check-bound transform 14 | (cond ((sb-c:policy node (= sb-c::insert-array-bounds-checks 0)) 15 | 'offset) 16 | ((not (sb-c::constant-lvar-p bound)) 17 | (sb-c::give-up-ir1-transform)) 18 | (t 19 | (let* ((dim (sb-c::lvar-value bound)) 20 | (n-bytes (sb-c::lvar-value n-bytes)) 21 | (upper-bound `(integer 0 (,(- dim n-bytes -1))))) 22 | (if (> n-bytes dim) 23 | (sb-c::give-up-ir1-transform) 24 | `(the ,upper-bound offset)))))) 25 | 26 | #.(flet ((specialized-includep (bitsize signedp setterp) 27 | (declare (ignorable bitsize signedp setterp)) 28 | ;; Bleh. No good way to solve this atm. 29 | ;; 30 | ;; Non-x86. No support. 31 | #-(or x86 x86-64) 32 | nil 33 | ;; x86 and x86-64. Can do everything. 34 | #+(or x86 x86-64) 35 | t) 36 | (generic-transform-form (fun-name arglist n-bytes 37 | setterp signedp big-endian-p) 38 | (let ((offset-type `(integer 0 ,(- array-dimension-limit n-bytes)))) 39 | `(sb-c:deftransform ,fun-name ,arglist 40 | `(locally (declare (type ,',offset-type offset)) 41 | ,',(if setterp 42 | (set-form 'vector 'offset 'value n-bytes big-endian-p) 43 | (ref-form 'vector 'offset n-bytes signedp big-endian-p))))))) 44 | (loop for i from 0 to #-x86-64 #b0111 #+x86-64 #b1011 45 | for bitsize = (ecase (ldb (byte 2 2) i) 46 | (0 16) 47 | (1 32) 48 | (2 64)) 49 | for signedp = (logbitp 1 i) 50 | for setterp = (logbitp 0 i) 51 | for byte-fun = (if setterp 52 | #'byte-set-fun-name 53 | #'byte-ref-fun-name) 54 | for big-fun = (funcall byte-fun bitsize signedp t) 55 | for little-fun = (funcall byte-fun bitsize signedp nil) 56 | for internal-big = (internalify big-fun) 57 | for internal-little = (internalify little-fun) 58 | for n-bytes = (truncate bitsize 8) 59 | for arg-type = `(,(if signedp 60 | 'signed-byte 61 | 'unsigned-byte) 62 | ,bitsize) 63 | for arglist = `(vector offset ,@(when setterp '(value))) 64 | for external-arg-types = `(array index ,@(when setterp 65 | `(,arg-type))) 66 | for internal-arg-types = (subst '(simple-array (unsigned-byte 8)) 'array 67 | external-arg-types) 68 | for transform-arglist = `(,arglist ,internal-arg-types ,arg-type) 69 | for specialized-big-transform 70 | = `(sb-c:deftransform ,big-fun ,transform-arglist 71 | '(,internal-big vector (%check-bound vector (length vector) offset ,n-bytes) 72 | ,@(when setterp '(value)))) 73 | for specialized-little-transform 74 | = (subst internal-little internal-big 75 | (subst little-fun big-fun 76 | specialized-big-transform)) 77 | ;; Also include inlining versions for when the argument type 78 | ;; is known to be a simple octet vector and we don't have a 79 | ;; native assembly implementation. 80 | for generic-big-transform 81 | = (generic-transform-form big-fun transform-arglist n-bytes 82 | setterp signedp t) 83 | for generic-little-transform 84 | = (generic-transform-form little-fun transform-arglist n-bytes 85 | setterp signedp nil) 86 | if (specialized-includep bitsize signedp setterp) 87 | collect specialized-big-transform into transforms 88 | else if (<= bitsize sb-vm:n-word-bits) 89 | collect generic-big-transform into transforms 90 | if (specialized-includep bitsize signedp setterp) 91 | collect specialized-little-transform into transforms 92 | else if (<= bitsize sb-vm:n-word-bits) 93 | collect generic-little-transform into transforms 94 | finally (return `(progn ,@transforms)))) 95 | 96 | );#+sbcl 97 | -------------------------------------------------------------------------------- /sbcl-opt/x86-64-vm.lisp: -------------------------------------------------------------------------------- 1 | ;;;; x86-64-vm.lisp -- VOP definitions SBCL 2 | 3 | #+sbcl 4 | (cl:in-package :sb-vm) 5 | 6 | #+(and sbcl x86-64) (progn 7 | 8 | (define-vop (%check-bound) 9 | (:translate nibbles::%check-bound) 10 | (:policy :fast-safe) 11 | (:args (array :scs (descriptor-reg)) 12 | (bound :scs (any-reg)) 13 | (index :scs (any-reg))) 14 | (:arg-types simple-array-unsigned-byte-8 positive-fixnum tagged-num 15 | (:constant (member 2 4 8 16))) 16 | (:info offset) 17 | (:temporary (:sc any-reg) temp) 18 | (:results (result :scs (any-reg))) 19 | (:result-types positive-fixnum) 20 | (:vop-var vop) 21 | (:generator 5 22 | (let ((error (generate-error-code vop 'invalid-array-index-error 23 | array bound index))) 24 | ;; We want to check the conditions: 25 | ;; 26 | ;; 0 <= INDEX 27 | ;; INDEX < BOUND 28 | ;; 0 <= INDEX + OFFSET 29 | ;; (INDEX + OFFSET) < BOUND 30 | ;; 31 | ;; We can do this naively with two unsigned checks: 32 | ;; 33 | ;; INDEX <_u BOUND 34 | ;; INDEX + OFFSET <_u BOUND 35 | ;; 36 | ;; If INDEX + OFFSET <_u BOUND, though, INDEX must be less than 37 | ;; BOUND. We *do* need to check for 0 <= INDEX, but that has 38 | ;; already been assured by higher-level machinery. 39 | (inst lea temp (make-ea :qword 40 | :index index :disp (fixnumize offset))) 41 | (inst cmp temp bound) 42 | (inst jmp :a error) 43 | (move result index)))) 44 | 45 | #.(flet ((frob (bitsize setterp signedp big-endian-p) 46 | (let* ((name (funcall (if setterp 47 | #'nibbles::byte-set-fun-name 48 | #'nibbles::byte-ref-fun-name) 49 | bitsize signedp big-endian-p)) 50 | (internal-name (nibbles::internalify name)) 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 ((swap-tn-inst-form (tn-name) 64 | (if (= bitsize 16) 65 | `(inst rol ,tn-name 8) 66 | `(inst bswap ,tn-name)))) 67 | `(define-vop (,name) 68 | (:translate ,internal-name) 69 | (:policy :fast-safe) 70 | (:args (vector :scs (descriptor-reg)) 71 | (index :scs (immediate unsigned-reg)) 72 | ,@(when setterp 73 | `((value* :scs (,result-sc) :target result)))) 74 | (:arg-types simple-array-unsigned-byte-8 75 | positive-fixnum 76 | ,@(when setterp 77 | `(,result-type))) 78 | ,@(when (and setterp big-endian-p) 79 | `((:temporary (:sc unsigned-reg 80 | :from (:load 0) 81 | :to (:result 0)) temp))) 82 | (:results (result :scs (,result-sc))) 83 | (:result-types ,result-type) 84 | (:generator 3 85 | (let* ((base-disp (- (* vector-data-offset n-word-bytes) 86 | other-pointer-lowtag)) 87 | (operand-size ,(ecase bitsize 88 | (16 :word) 89 | (32 :dword) 90 | (64 :qword))) 91 | (result-in-size (reg-in-size result operand-size)) 92 | ,@(when setterp 93 | '((value (reg-in-size value* operand-size)))) 94 | ,@(when (and setterp big-endian-p) 95 | '((temp (reg-in-size temp operand-size)))) 96 | (memref (sc-case index 97 | (immediate 98 | (make-ea operand-size :base vector 99 | :disp (+ (tn-value index) base-disp))) 100 | (t 101 | (make-ea operand-size 102 | :base vector :index index 103 | :disp base-disp))))) 104 | (declare (ignorable result-in-size)) 105 | ,@(when (and setterp big-endian-p) 106 | `((inst mov temp value) 107 | ,(swap-tn-inst-form 'temp))) 108 | ,(if setterp 109 | `(inst mov memref ,(if big-endian-p 110 | 'temp 111 | 'value)) 112 | `(inst ,ref-mov-insn 113 | ,(if (and big-endian-p (= bitsize 32)) 114 | 'result-in-size 115 | 'result) 116 | memref)) 117 | ,@(if setterp 118 | '((move result value*)) 119 | (when big-endian-p 120 | `(,(swap-tn-inst-form (if (/= bitsize 64) 121 | 'result-in-size 122 | 'result)) 123 | ,(when (and (/= bitsize 64) signedp) 124 | `(inst movsx result result-in-size)))))))))))) 125 | (loop for i from 0 upto #b10111 126 | for bitsize = (ecase (ldb (byte 2 3) i) 127 | (0 16) 128 | (1 32) 129 | (2 64)) 130 | for setterp = (logbitp 2 i) 131 | for signedp = (logbitp 1 i) 132 | for big-endian-p = (logbitp 0 i) 133 | collect (frob bitsize setterp signedp big-endian-p) into forms 134 | finally (return `(progn ,@forms)))) 135 | 136 | );#+(and sbcl x86-64) 137 | -------------------------------------------------------------------------------- /sbcl-opt/x86-vm.lisp: -------------------------------------------------------------------------------- 1 | ;;;; x86-vm.lisp -- VOP definitions for SBCL 2 | 3 | #+sbcl 4 | (cl:in-package :sb-vm) 5 | 6 | #+(and sbcl x86) (progn 7 | 8 | (define-vop (%check-bound) 9 | (:translate nibbles::%check-bound) 10 | (:policy :fast-safe) 11 | (:args (array :scs (descriptor-reg)) 12 | (bound :scs (any-reg)) 13 | (index :scs (any-reg))) 14 | (:arg-types simple-array-unsigned-byte-8 positive-fixnum tagged-num 15 | (:constant (member 2 4 8 16))) 16 | (:info offset) 17 | (:temporary (:sc any-reg) temp) 18 | (:results (result :scs (any-reg))) 19 | (:result-types positive-fixnum) 20 | (:vop-var vop) 21 | (:generator 5 22 | (let ((error (generate-error-code vop 'invalid-array-index-error 23 | array bound index))) 24 | ;; We want to check the conditions: 25 | ;; 26 | ;; 0 <= INDEX 27 | ;; INDEX < BOUND 28 | ;; 0 <= INDEX + OFFSET 29 | ;; (INDEX + OFFSET) < BOUND 30 | ;; 31 | ;; We can do this naively with two unsigned checks: 32 | ;; 33 | ;; INDEX <_u BOUND 34 | ;; INDEX + OFFSET <_u BOUND 35 | ;; 36 | ;; If INDEX + OFFSET <_u BOUND, though, INDEX must be less than 37 | ;; BOUND. We *do* need to check for 0 <= INDEX, but that has 38 | ;; already been assured by higher-level machinery. 39 | (inst lea temp (make-ea :dword :index index :disp (fixnumize offset))) 40 | (inst cmp temp bound) 41 | (inst jmp :a error) 42 | (move result index)))) 43 | 44 | #.(flet ((frob (setterp signedp big-endian-p) 45 | (let* ((name (funcall (if setterp 46 | #'nibbles::byte-set-fun-name 47 | #'nibbles::byte-ref-fun-name) 48 | 16 signedp big-endian-p)) 49 | (internal-name (nibbles::internalify name)) 50 | (result-sc (if signedp 'signed-reg 'unsigned-reg)) 51 | (result-type (if signedp 'signed-num 'unsigned-num))) 52 | `(define-vop (,name) 53 | (:translate ,internal-name) 54 | (:policy :fast-safe) 55 | (:args (vector :scs (descriptor-reg)) 56 | (index :scs (immediate unsigned-reg)) 57 | ,@(when setterp 58 | `((value :scs (,result-sc) :target result)))) 59 | (:arg-types simple-array-unsigned-byte-8 60 | positive-fixnum 61 | ,@(when setterp 62 | `(,result-type))) 63 | ,@(when (or setterp big-endian-p) 64 | `((:temporary (:sc unsigned-reg :offset eax-offset 65 | :from ,(if setterp 66 | '(:load 0) 67 | '(:argument 2)) 68 | :to (:result 0)) eax))) 69 | (:results (result :scs (,result-sc))) 70 | (:result-types ,result-type) 71 | (:generator 3 72 | (let* ((base-disp (- (* vector-data-offset n-word-bytes) 73 | other-pointer-lowtag)) 74 | (memref (sc-case index 75 | (immediate 76 | (make-ea :word :base vector 77 | :disp (+ (tn-value index) base-disp))) 78 | (t 79 | (make-ea :word :base vector 80 | :index index 81 | :disp base-disp))))) 82 | ,(when setterp 83 | '(move eax value)) 84 | ,(when (and setterp big-endian-p) 85 | '(inst rol ax-tn 8)) 86 | ,(if setterp 87 | '(inst mov memref ax-tn) 88 | `(inst ,(if big-endian-p 89 | 'mov 90 | (if signedp 91 | 'movsx 92 | 'movzx)) 93 | ,(if big-endian-p 94 | 'ax-tn 95 | 'result) 96 | memref)) 97 | ,@(if setterp 98 | '((move result value)) 99 | (when big-endian-p 100 | `(eax ; hack so that it looks used 101 | (inst rol ax-tn 8) 102 | (inst ,(if signedp 'movsx 'movzx) 103 | result ax-tn)))))))))) 104 | (loop for i from 0 upto #b111 105 | for setterp = (logbitp 2 i) 106 | for signedp = (logbitp 1 i) 107 | for big-endian-p = (logbitp 0 i) 108 | collect (frob setterp signedp big-endian-p) into forms 109 | finally (return `(progn ,@forms)))) 110 | 111 | #.(flet ((frob (setterp signedp big-endian-p) 112 | (let* ((name (funcall (if setterp 113 | #'nibbles::byte-set-fun-name 114 | #'nibbles::byte-ref-fun-name) 115 | 32 signedp big-endian-p)) 116 | (internal-name (nibbles::internalify name)) 117 | (result-sc (if signedp 'signed-reg 'unsigned-reg)) 118 | (result-type (if signedp 'signed-num 'unsigned-num))) 119 | `(define-vop (,name) 120 | (:translate ,internal-name) 121 | (:policy :fast-safe) 122 | (:args (vector :scs (descriptor-reg)) 123 | (index :scs (immediate unsigned-reg)) 124 | ,@(when setterp 125 | `((value :scs (,result-sc) :target result)))) 126 | (:arg-types simple-array-unsigned-byte-8 127 | positive-fixnum 128 | ,@(when setterp 129 | `(,result-type))) 130 | ,@(when (and setterp big-endian-p) 131 | `((:temporary (:sc unsigned-reg 132 | :from (:load 0) 133 | :to (:result 0)) temp))) 134 | (:results (result :scs (,result-sc))) 135 | (:result-types ,result-type) 136 | (:generator 3 137 | (let* ((base-disp (- (* vector-data-offset n-word-bytes) 138 | other-pointer-lowtag)) 139 | (memref (sc-case index 140 | (immediate 141 | (make-ea :dword :base vector 142 | :disp (+ (tn-value index) base-disp))) 143 | (t 144 | (make-ea :dword :base vector :index index 145 | :disp base-disp))))) 146 | ,@(when (and setterp big-endian-p) 147 | `((inst mov temp value) 148 | (inst bswap temp))) 149 | ,(if setterp 150 | `(inst mov memref ,(if big-endian-p 151 | 'temp 152 | 'value)) 153 | '(inst mov result memref)) 154 | ,(if setterp 155 | '(move result value) 156 | (when big-endian-p 157 | '(inst bswap result))))))))) 158 | (loop for i from 0 upto #b111 159 | for setterp = (logbitp 2 i) 160 | for signedp = (logbitp 1 i) 161 | for big-endian-p = (logbitp 0 i) 162 | collect (frob setterp signedp big-endian-p) into forms 163 | finally (return `(progn ,@forms)))) 164 | 165 | );#+(and sbcl x86) 166 | -------------------------------------------------------------------------------- /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 | (dotimes (i n-bytes v) 7 | ;; READ-SEQUENCE would likely be more efficient here, but it does 8 | ;; not have the semantics we want--in particular, the blocking 9 | ;; semantics of READ-SEQUENCE are potentially bad. It's not clear 10 | ;; that READ-BYTE is any better here, though... 11 | (setf (aref v i) (read-byte stream)))) 12 | 13 | (declaim (inline read-byte* write-byte*)) 14 | (defun read-byte* (stream n-bytes reffer) 15 | (let ((v (make-array n-bytes :element-type '(unsigned-byte 8)))) 16 | (declare (dynamic-extent v)) 17 | (read-n-bytes-into stream n-bytes v) 18 | (funcall reffer v 0))) 19 | 20 | (defun write-byte* (integer stream n-bytes setter) 21 | (let ((v (make-array n-bytes :element-type '(unsigned-byte 8)))) 22 | (declare (dynamic-extent v)) 23 | (funcall setter v 0 integer) 24 | (write-sequence v stream) 25 | integer)) 26 | 27 | (declaim (inline read-into-vector*)) 28 | (defun read-into-vector* (stream vector start end n-bytes reffer) 29 | (declare (type function reffer)) 30 | (let ((v (make-array n-bytes :element-type '(unsigned-byte 8)))) 31 | (declare (dynamic-extent v)) 32 | (loop for i from start below end 33 | do (read-n-bytes-into stream n-bytes v) 34 | (setf (aref vector i) (funcall reffer v 0)) 35 | finally (return vector)))) 36 | 37 | (defun read-into-list* (stream list start end n-bytes reffer) 38 | (declare (type function reffer)) 39 | (do ((end (or end (length list))) 40 | (v (make-array n-bytes :element-type '(unsigned-byte 8))) 41 | (rem (nthcdr start list) (rest rem)) 42 | (i start (1+ i))) 43 | ((or (endp rem) (>= i end)) list) 44 | (declare (dynamic-extent v)) 45 | (read-n-bytes-into stream n-bytes v) 46 | (setf (first rem) (funcall reffer v 0)))) 47 | 48 | (declaim (inline read-fresh-sequence)) 49 | (defun read-fresh-sequence (result-type stream count 50 | element-type n-bytes reffer) 51 | (ecase result-type 52 | (list 53 | (let ((list (make-list count))) 54 | (read-into-list* stream list 0 count n-bytes reffer))) 55 | (vector 56 | (let ((vector (make-array count :element-type element-type))) 57 | (read-into-vector* stream vector 0 count n-bytes reffer))))) 58 | 59 | (defun write-sequence-with-writer (seq stream start end writer) 60 | (declare (type function writer)) 61 | (etypecase seq 62 | (list 63 | (mapc (lambda (e) (funcall writer e stream)) 64 | (subseq seq start end)) 65 | seq) 66 | (vector 67 | (loop with end = (or end (length seq)) 68 | for i from start below end 69 | do (funcall writer (aref seq i) stream) 70 | finally (return seq))))) 71 | 72 | (defun read-into-sequence (seq stream start end n-bytes reffer) 73 | (etypecase seq 74 | (list 75 | (read-into-list* stream seq start end n-bytes reffer)) 76 | (vector 77 | (let ((end (or end (length seq)))) 78 | (read-into-vector* stream seq start end n-bytes reffer))))) 79 | 80 | #.(loop for i from 0 upto #b10111 81 | for bitsize = (ecase (ldb (byte 2 3) i) 82 | (0 16) 83 | (1 32) 84 | (2 64)) 85 | for readp = (logbitp 2 i) 86 | for signedp = (logbitp 1 i) 87 | for big-endian-p = (logbitp 0 i) 88 | for name = (stream-ref-fun-name bitsize readp signedp big-endian-p) 89 | for n-bytes = (truncate bitsize 8) 90 | for byte-fun = (if readp 91 | (byte-ref-fun-name bitsize signedp big-endian-p) 92 | (byte-set-fun-name bitsize signedp big-endian-p)) 93 | for byte-arglist = (if readp '(stream) '(integer stream)) 94 | for subfun = (if readp 'read-byte* 'write-byte*) 95 | for element-type = `(,(if signedp 'signed-byte 'unsigned-byte) ,bitsize) 96 | collect `(progn 97 | ,@(when readp 98 | `((declaim (ftype (function (t) (values ,element-type &optional)) ,name)))) 99 | (defun ,name ,byte-arglist 100 | (,subfun ,@byte-arglist ,n-bytes #',byte-fun))) into forms 101 | if readp 102 | collect `(defun ,(stream-seq-fun-name bitsize t signedp big-endian-p) 103 | (result-type stream count) 104 | ,(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)." 105 | bitsize signedp big-endian-p) 106 | (read-fresh-sequence result-type stream count 107 | ',element-type ,n-bytes #',byte-fun)) into forms 108 | else 109 | collect `(defun ,(stream-seq-fun-name bitsize nil signedp big-endian-p) 110 | (seq stream &key (start 0) end) 111 | ,(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)." 112 | bitsize signedp big-endian-p) 113 | (write-sequence-with-writer seq stream start end #',name)) into forms 114 | if readp 115 | collect `(defun ,(stream-into-seq-fun-name bitsize signedp big-endian-p) 116 | (seq stream &key (start 0) end) 117 | ,(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)." 118 | bitsize signedp big-endian-p) 119 | (read-into-sequence seq stream start end ,n-bytes #',byte-fun)) into forms 120 | finally (return `(progn ,@forms))) 121 | 122 | #.(loop for i from 0 upto #b111 123 | for float-type = (if (logbitp 2 i) 'double 'single) 124 | for readp = (logbitp 1 i) 125 | for big-endian-p = (logbitp 0 i) 126 | for name = (stream-float-ref-fun-name float-type readp big-endian-p) 127 | for n-bytes = (ecase float-type (double 8) (single 4)) 128 | for single-fun = (if readp 129 | (float-ref-fun-name float-type big-endian-p) 130 | (float-set-fun-name float-type big-endian-p)) 131 | for arglist = (if readp '(stream) '(float stream)) 132 | for subfun = (if readp 'read-byte* 'write-byte*) 133 | for element-type = (ecase float-type (double 'double-float) (single 'single-float)) 134 | collect `(defun ,name ,arglist 135 | (,subfun ,@arglist ,n-bytes #',single-fun)) into forms 136 | if readp 137 | collect `(defun ,(stream-float-seq-fun-name float-type t big-endian-p) 138 | (result-type stream count) 139 | ,(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)." 140 | element-type big-endian-p) 141 | (read-fresh-sequence result-type stream count 142 | ',element-type ,n-bytes #',single-fun)) into forms 143 | else 144 | collect `(defun ,(stream-float-seq-fun-name float-type nil big-endian-p) 145 | (seq stream &key (start 0) end) 146 | ,(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)." 147 | element-type big-endian-p) 148 | (write-sequence-with-writer seq stream start end #',name)) into forms 149 | if readp 150 | collect `(defun ,(stream-float-into-seq-fun-name float-type big-endian-p) 151 | (seq stream &key (start 0) end) 152 | ,(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)." 153 | element-type big-endian-p) 154 | (read-into-sequence seq stream start end ,n-bytes #',single-fun)) into forms 155 | finally (return `(progn ,@forms))) 156 | -------------------------------------------------------------------------------- /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 | (ev (make-array n-values 48 | :element-type `(,byte-kind ,bitsize) 49 | :adjustable t)) 50 | (i 0 (1+ i)) 51 | (j 0) 52 | (combiner (make-byte-combiner bytesize big-endian-p))) 53 | ((>= i n-bytes-to-read) ev) 54 | (multiple-value-bind (aggregate set-p) (funcall combiner (aref byte-vector i)) 55 | (when set-p 56 | (setf (aref ev j) 57 | (if (and signedp (logbitp (1- bitsize) aggregate)) 58 | (dpb aggregate (byte bitsize 0) -1) 59 | aggregate)) 60 | (unless rolling-p 61 | (setf combiner (make-byte-combiner bytesize big-endian-p))) 62 | (incf j))))) 63 | 64 | (defvar *default-n-values* 4096) 65 | 66 | (defun generate-random-test (bitsize signedp big-endian-p 67 | &optional (n-values *default-n-values*)) 68 | (let* ((n-bytes (truncate bitsize 8)) 69 | (total-octets (+ n-values (1- n-bytes))) 70 | (random-octets (generate-random-octet-vector total-octets)) 71 | (expected-vector 72 | (generate-reffed-values random-octets bitsize signedp big-endian-p))) 73 | (values random-octets expected-vector))) 74 | 75 | (defun compile-quietly (form) 76 | (handler-bind ((style-warning #'muffle-warning) 77 | #+sbcl (sb-ext:compiler-note #'muffle-warning)) 78 | (compile nil form))) 79 | 80 | (defun ref-test (reffer bitsize signedp big-endian-p 81 | &optional (n-octets *default-n-values*)) 82 | (multiple-value-bind (byte-vector expected-vector) 83 | (generate-random-test bitsize signedp big-endian-p n-octets) 84 | (flet ((run-test (reffer) 85 | (loop for i from 0 below n-octets 86 | for j from 0 87 | do (let ((reffed-val (funcall reffer byte-vector i)) 88 | (expected-val (aref expected-vector j))) 89 | (unless (= reffed-val expected-val) 90 | (error "wanted ~D, got ~D from ~A" 91 | expected-val reffed-val 92 | (subseq byte-vector i 93 | (+ i (truncate bitsize 8)))))) 94 | finally (return :ok)))) 95 | (run-test reffer) 96 | (when (typep byte-vector '(simple-array (unsigned-byte 8) (*))) 97 | (let ((compiled (compile-quietly 98 | `(lambda (v i) 99 | (declare (type (simple-array (unsigned-byte 8) (*)) v)) 100 | (declare (type (integer 0 #.(1- array-dimension-limit)) i)) 101 | (declare (optimize speed (debug 0))) 102 | (,reffer v i))))) 103 | (run-test compiled)))))) 104 | 105 | (defun set-test (reffer bitsize signedp big-endian-p 106 | &optional (n-octets *default-n-values*)) 107 | ;; We use GET-SETF-EXPANSION to avoid reaching too deeply into 108 | ;; internals. This bit relies on knowing that the writer-form will be 109 | ;; a simple function call whose CAR is the internal setter, but I 110 | ;; think that's a bit better than :: references everywhere. 111 | (multiple-value-bind (vars vals store-vars writer-form reader-form) 112 | (get-setf-expansion `(,reffer x i)) 113 | (declare (ignore vars vals store-vars reader-form)) 114 | (let ((setter (car writer-form))) 115 | ;; Sanity check. 116 | (unless (eq (symbol-package setter) (find-package :nibbles)) 117 | (error "need to update setter tests!")) 118 | (multiple-value-bind (byte-vector expected-vector) 119 | (generate-random-test bitsize signedp big-endian-p n-octets) 120 | (flet ((run-test (setter) 121 | (loop with fill-vec = (let ((v (copy-seq byte-vector))) 122 | (fill v 0) 123 | v) 124 | for i from 0 below n-octets 125 | for j from 0 126 | do (funcall setter fill-vec i (aref expected-vector j)) 127 | finally (return 128 | (if (mismatch fill-vec byte-vector) 129 | (error "wanted ~A, got ~A" byte-vector fill-vec) 130 | :ok))))) 131 | (run-test setter) 132 | (when (typep byte-vector '(simple-array (unsigned-byte 8) (*))) 133 | (let ((compiled (compile-quietly 134 | `(lambda (v i new) 135 | (declare (type (simple-array (unsigned-byte 8) (*)) v)) 136 | (declare (type (integer 0 #.(1- array-dimension-limit)) i)) 137 | (declare (type (,(if signedp 'signed-byte 'unsigned-byte) 138 | ,bitsize) new)) 139 | (declare (optimize speed (debug 0))) 140 | (,setter v i new))))) 141 | (run-test compiled)))))))) 142 | 143 | ;;; Big-endian integer ref tests 144 | 145 | (rtest:deftest :ub16ref/be 146 | (ref-test 'nibbles:ub16ref/be 16 nil t) 147 | :ok) 148 | 149 | (rtest:deftest :sb16ref/be 150 | (ref-test 'nibbles:sb16ref/be 16 t t) 151 | :ok) 152 | 153 | (rtest:deftest :ub32ref/be 154 | (ref-test 'nibbles:ub32ref/be 32 nil t) 155 | :ok) 156 | 157 | (rtest:deftest :sb32ref/be 158 | (ref-test 'nibbles:sb32ref/be 32 t t) 159 | :ok) 160 | 161 | (rtest:deftest :ub64ref/be 162 | (ref-test 'nibbles:ub64ref/be 64 nil t) 163 | :ok) 164 | 165 | (rtest:deftest :sb64ref/be 166 | (ref-test 'nibbles:sb64ref/be 64 t t) 167 | :ok) 168 | 169 | ;;; Big-endian set tests 170 | 171 | (rtest:deftest :ub16set/be 172 | (set-test 'nibbles:ub16ref/be 16 nil t) 173 | :ok) 174 | 175 | (rtest:deftest :sb16set/be 176 | (set-test 'nibbles:sb16ref/be 16 t t) 177 | :ok) 178 | 179 | (rtest:deftest :ub32set/be 180 | (set-test 'nibbles:ub32ref/be 32 nil t) 181 | :ok) 182 | 183 | (rtest:deftest :sb32set/be 184 | (set-test 'nibbles:sb32ref/be 32 t t) 185 | :ok) 186 | 187 | (rtest:deftest :ub64set/be 188 | (set-test 'nibbles:ub64ref/be 64 nil t) 189 | :ok) 190 | 191 | (rtest:deftest :sb64set/be 192 | (set-test 'nibbles:sb64ref/be 64 t t) 193 | :ok) 194 | 195 | ;;; Little-endian integer ref tests 196 | 197 | (rtest:deftest :ub16ref/le 198 | (ref-test 'nibbles:ub16ref/le 16 nil nil) 199 | :ok) 200 | 201 | (rtest:deftest :sb16ref/le 202 | (ref-test 'nibbles:sb16ref/le 16 t nil) 203 | :ok) 204 | 205 | (rtest:deftest :ub32ref/le 206 | (ref-test 'nibbles:ub32ref/le 32 nil nil) 207 | :ok) 208 | 209 | (rtest:deftest :sb32ref/le 210 | (ref-test 'nibbles:sb32ref/le 32 t nil) 211 | :ok) 212 | 213 | (rtest:deftest :ub64ref/le 214 | (ref-test 'nibbles:ub64ref/le 64 nil nil) 215 | :ok) 216 | 217 | (rtest:deftest :sb64ref/le 218 | (ref-test 'nibbles:sb64ref/le 64 t nil) 219 | :ok) 220 | 221 | ;;; Little-endian set tests 222 | 223 | (rtest:deftest :ub16set/le 224 | (set-test 'nibbles:ub16ref/le 16 nil nil) 225 | :ok) 226 | 227 | (rtest:deftest :sb16set/le 228 | (set-test 'nibbles:sb16ref/le 16 t nil) 229 | :ok) 230 | 231 | (rtest:deftest :ub32set/le 232 | (set-test 'nibbles:ub32ref/le 32 nil nil) 233 | :ok) 234 | 235 | (rtest:deftest :sb32set/le 236 | (set-test 'nibbles:sb32ref/le 32 t nil) 237 | :ok) 238 | 239 | (rtest:deftest :ub64set/le 240 | (set-test 'nibbles:ub64ref/le 64 nil nil) 241 | :ok) 242 | 243 | (rtest:deftest :sb64set/le 244 | (set-test 'nibbles:sb64ref/le 64 t nil) 245 | :ok) 246 | 247 | ;;; Stream reading tests 248 | 249 | (defvar *path* #.*compile-file-truename*) 250 | 251 | (defun read-file-as-octets (pathname) 252 | (with-open-file (stream pathname :direction :input 253 | :element-type '(unsigned-byte 8)) 254 | (let ((v (nibbles:make-octet-vector (file-length stream)))) 255 | (read-sequence v stream) 256 | v))) 257 | 258 | (defun read-test (reader bitsize signedp big-endian-p) 259 | (let* ((pathname *path*) 260 | (file-contents (read-file-as-octets pathname)) 261 | (expected-values (generate-reffed-values file-contents bitsize 262 | signedp big-endian-p))) 263 | (with-open-file (stream pathname :direction :input 264 | :element-type '(unsigned-byte 8)) 265 | (loop with n-values = (length expected-values) 266 | for i from 0 below n-values 267 | do (file-position stream i) 268 | (let ((read-value (funcall reader stream)) 269 | (expected-value (aref expected-values i))) 270 | (unless (= read-value expected-value) 271 | (return :bad))) 272 | finally (return :ok))))) 273 | 274 | (defun read-sequence-test (result-type reader bitsize signedp big-endian-p) 275 | (let* ((pathname *path*) 276 | (file-contents (subseq (read-file-as-octets pathname) 0 8)) 277 | (expected-values (generate-reffed-values file-contents bitsize 278 | signedp big-endian-p nil))) 279 | (with-open-file (stream pathname :direction :input 280 | :element-type '(unsigned-byte 8)) 281 | (let* ((n-values (truncate (length file-contents) 282 | (truncate bitsize 8))) 283 | (read-values (funcall reader result-type stream n-values))) 284 | (if (or (not (typep read-values result-type)) 285 | (mismatch read-values expected-values)) 286 | :bad 287 | :ok))))) 288 | 289 | (rtest:deftest :read-ub16/be 290 | (read-test 'nibbles:read-ub16/be 16 nil t) 291 | :ok) 292 | 293 | (rtest:deftest :read-sb16/be 294 | (read-test 'nibbles:read-sb16/be 16 t t) 295 | :ok) 296 | 297 | (rtest:deftest :read-ub32/be 298 | (read-test 'nibbles:read-ub32/be 32 nil t) 299 | :ok) 300 | 301 | (rtest:deftest :read-sb32/be 302 | (read-test 'nibbles:read-sb32/be 32 t t) 303 | :ok) 304 | 305 | (rtest:deftest :read-ub64/be 306 | (read-test 'nibbles:read-ub64/be 64 nil t) 307 | :ok) 308 | 309 | (rtest:deftest :read-sb64/be 310 | (read-test 'nibbles:read-sb64/be 64 t t) 311 | :ok) 312 | 313 | (rtest:deftest :read-ub16/le 314 | (read-test 'nibbles:read-ub16/le 16 nil nil) 315 | :ok) 316 | 317 | (rtest:deftest :read-sb16/le 318 | (read-test 'nibbles:read-sb16/le 16 t nil) 319 | :ok) 320 | 321 | (rtest:deftest :read-ub32/le 322 | (read-test 'nibbles:read-ub32/le 32 nil nil) 323 | :ok) 324 | 325 | (rtest:deftest :read-sb32/le 326 | (read-test 'nibbles:read-sb32/le 32 t nil) 327 | :ok) 328 | 329 | (rtest:deftest :read-ub64/le 330 | (read-test 'nibbles:read-ub64/le 64 nil nil) 331 | :ok) 332 | 333 | (rtest:deftest :read-sb64/le 334 | (read-test 'nibbles:read-sb64/le 64 t nil) 335 | :ok) 336 | 337 | (rtest:deftest :read-ub16/be-vector 338 | (read-sequence-test 'vector 'nibbles:read-ub16/be-sequence 16 nil t) 339 | :ok) 340 | 341 | (rtest:deftest :read-sb16/be-vector 342 | (read-sequence-test 'vector 'nibbles:read-sb16/be-sequence 16 t t) 343 | :ok) 344 | 345 | (rtest:deftest :read-ub32/be-vector 346 | (read-sequence-test 'vector 'nibbles:read-ub32/be-sequence 32 nil t) 347 | :ok) 348 | 349 | (rtest:deftest :read-sb32/be-vector 350 | (read-sequence-test 'vector 'nibbles:read-sb32/be-sequence 32 t t) 351 | :ok) 352 | 353 | (rtest:deftest :read-ub64/be-vector 354 | (read-sequence-test 'vector 'nibbles:read-ub64/be-sequence 64 nil t) 355 | :ok) 356 | 357 | (rtest:deftest :read-sb64/be-vector 358 | (read-sequence-test 'vector 'nibbles:read-sb64/be-sequence 64 t t) 359 | :ok) 360 | 361 | (rtest:deftest :read-ub16/le-vector 362 | (read-sequence-test 'vector 'nibbles:read-ub16/le-sequence 16 nil nil) 363 | :ok) 364 | 365 | (rtest:deftest :read-sb16/le-vector 366 | (read-sequence-test 'vector 'nibbles:read-sb16/le-sequence 16 t nil) 367 | :ok) 368 | 369 | (rtest:deftest :read-ub32/le-vector 370 | (read-sequence-test 'vector 'nibbles:read-ub32/le-sequence 32 nil nil) 371 | :ok) 372 | 373 | (rtest:deftest :read-sb32/le-vector 374 | (read-sequence-test 'vector 'nibbles:read-sb32/le-sequence 32 t nil) 375 | :ok) 376 | 377 | (rtest:deftest :read-ub64/le-vector 378 | (read-sequence-test 'vector 'nibbles:read-ub64/le-sequence 64 nil nil) 379 | :ok) 380 | 381 | (rtest:deftest :read-sb64/le-vector 382 | (read-sequence-test 'vector 'nibbles:read-sb64/le-sequence 64 t nil) 383 | :ok) 384 | 385 | (rtest:deftest :read-ub16/be-list 386 | (read-sequence-test 'list 'nibbles:read-ub16/be-sequence 16 nil t) 387 | :ok) 388 | 389 | (rtest:deftest :read-sb16/be-list 390 | (read-sequence-test 'list 'nibbles:read-sb16/be-sequence 16 t t) 391 | :ok) 392 | 393 | (rtest:deftest :read-ub32/be-list 394 | (read-sequence-test 'list 'nibbles:read-ub32/be-sequence 32 nil t) 395 | :ok) 396 | 397 | (rtest:deftest :read-sb32/be-list 398 | (read-sequence-test 'list 'nibbles:read-sb32/be-sequence 32 t t) 399 | :ok) 400 | 401 | (rtest:deftest :read-ub64/be-list 402 | (read-sequence-test 'list 'nibbles:read-ub64/be-sequence 64 nil t) 403 | :ok) 404 | 405 | (rtest:deftest :read-sb64/be-list 406 | (read-sequence-test 'list 'nibbles:read-sb64/be-sequence 64 t t) 407 | :ok) 408 | 409 | (rtest:deftest :read-ub16/le-list 410 | (read-sequence-test 'list 'nibbles:read-ub16/le-sequence 16 nil nil) 411 | :ok) 412 | 413 | (rtest:deftest :read-sb16/le-list 414 | (read-sequence-test 'list 'nibbles:read-sb16/le-sequence 16 t nil) 415 | :ok) 416 | 417 | (rtest:deftest :read-ub32/le-list 418 | (read-sequence-test 'list 'nibbles:read-ub32/le-sequence 32 nil nil) 419 | :ok) 420 | 421 | (rtest:deftest :read-sb32/le-list 422 | (read-sequence-test 'list 'nibbles:read-sb32/le-sequence 32 t nil) 423 | :ok) 424 | 425 | (rtest:deftest :read-ub64/le-list 426 | (read-sequence-test 'list 'nibbles:read-ub64/le-sequence 64 nil nil) 427 | :ok) 428 | 429 | (rtest:deftest :read-sb64/le-list 430 | (read-sequence-test 'list 'nibbles:read-sb64/le-sequence 64 t nil) 431 | :ok) 432 | 433 | ;;; Stream writing tests 434 | 435 | (defvar *output-directory* 436 | (merge-pathnames (make-pathname :name nil :type nil 437 | :directory '(:relative "test-output")) 438 | (make-pathname :directory (pathname-directory *path*)))) 439 | 440 | (defun write-test (writer bitsize signedp big-endian-p) 441 | (multiple-value-bind (byte-vector expected-values) 442 | (generate-random-test bitsize signedp big-endian-p) 443 | (let ((tmpfile (make-pathname :name "tmp" :defaults *output-directory*))) 444 | (ensure-directories-exist tmpfile) 445 | (with-open-file (stream tmpfile :direction :output 446 | :element-type '(unsigned-byte 8) 447 | :if-does-not-exist :create 448 | :if-exists :supersede) 449 | (loop with n-values = (length expected-values) 450 | for i from 0 below n-values 451 | do (file-position stream i) 452 | (funcall writer (aref expected-values i) stream))) 453 | (let ((file-contents (read-file-as-octets tmpfile))) 454 | (delete-file tmpfile) 455 | (if (mismatch byte-vector file-contents) 456 | :bad 457 | :ok))))) 458 | 459 | (defun read-sequence-from-file (filename seq-type reader n-values) 460 | (with-open-file (stream filename :direction :input 461 | :element-type '(unsigned-byte 8) 462 | :if-does-not-exist :error) 463 | (funcall reader seq-type stream n-values))) 464 | 465 | (defun write-sequence-test (seq-type reader writer 466 | bitsize signedp big-endian-p) 467 | (multiple-value-bind (byte-vector expected-values) 468 | (generate-random-test bitsize signedp big-endian-p) 469 | (declare (ignore byte-vector)) 470 | (let ((tmpfile (make-pathname :name "tmp" :defaults *output-directory*)) 471 | (values-seq (coerce expected-values seq-type))) 472 | (ensure-directories-exist tmpfile) 473 | (flet ((run-random-test (values expected-start expected-end) 474 | (with-open-file (stream tmpfile :direction :output 475 | :element-type '(unsigned-byte 8) 476 | :if-does-not-exist :create 477 | :if-exists :supersede) 478 | (funcall writer values stream :start expected-start 479 | :end expected-end)) 480 | (let ((file-contents (read-sequence-from-file tmpfile 481 | seq-type 482 | reader 483 | (- expected-end expected-start)))) 484 | (mismatch values file-contents 485 | :start1 expected-start 486 | :end1 expected-end)))) 487 | (let* ((block-size (truncate (length expected-values) 4)) 488 | (upper-quartile (* block-size 3))) 489 | (unwind-protect 490 | (loop repeat 32 491 | when (run-random-test values-seq (random block-size) 492 | (+ upper-quartile 493 | (random block-size))) 494 | do (return :bad) 495 | finally (return :ok)) 496 | (delete-file tmpfile))))))) 497 | 498 | (rtest:deftest :write-ub16/be 499 | (write-test 'nibbles:write-ub16/be 16 nil t) 500 | :ok) 501 | 502 | (rtest:deftest :write-sb16/be 503 | (write-test 'nibbles:write-sb16/be 16 t t) 504 | :ok) 505 | 506 | (rtest:deftest :write-ub32/be 507 | (write-test 'nibbles:write-ub32/be 32 nil t) 508 | :ok) 509 | 510 | (rtest:deftest :write-sb32/be 511 | (write-test 'nibbles:write-sb32/be 32 t t) 512 | :ok) 513 | 514 | (rtest:deftest :write-ub64/be 515 | (write-test 'nibbles:write-ub64/be 64 nil t) 516 | :ok) 517 | 518 | (rtest:deftest :write-sb64/be 519 | (write-test 'nibbles:write-sb64/be 64 t t) 520 | :ok) 521 | 522 | (rtest:deftest :write-ub16/le 523 | (write-test 'nibbles:write-ub16/le 16 nil nil) 524 | :ok) 525 | 526 | (rtest:deftest :write-sb16/le 527 | (write-test 'nibbles:write-sb16/le 16 t nil) 528 | :ok) 529 | 530 | (rtest:deftest :write-ub32/le 531 | (write-test 'nibbles:write-ub32/le 32 nil nil) 532 | :ok) 533 | 534 | (rtest:deftest :write-sb32/le 535 | (write-test 'nibbles:write-sb32/le 32 t nil) 536 | :ok) 537 | 538 | (rtest:deftest :write-ub64/le 539 | (write-test 'nibbles:write-ub64/le 64 nil nil) 540 | :ok) 541 | 542 | (rtest:deftest :write-sb64/le 543 | (write-test 'nibbles:write-sb64/le 64 t nil) 544 | :ok) 545 | 546 | (rtest:deftest :write-ub16/be-vector 547 | (write-sequence-test 'vector 548 | 'nibbles:read-ub16/be-sequence 549 | 'nibbles:write-ub16/be-sequence 16 nil t) 550 | :ok) 551 | 552 | (rtest:deftest :write-sb16/be-vector 553 | (write-sequence-test 'vector 554 | 'nibbles:read-sb16/be-sequence 555 | 'nibbles:write-sb16/be-sequence 16 t t) 556 | :ok) 557 | 558 | (rtest:deftest :write-ub32/be-vector 559 | (write-sequence-test 'vector 560 | 'nibbles:read-ub32/be-sequence 561 | 'nibbles:write-ub32/be-sequence 32 nil t) 562 | :ok) 563 | 564 | (rtest:deftest :write-sb32/be-vector 565 | (write-sequence-test 'vector 566 | 'nibbles:read-sb32/be-sequence 567 | 'nibbles:write-sb32/be-sequence 32 t t) 568 | :ok) 569 | 570 | (rtest:deftest :write-ub64/be-vector 571 | (write-sequence-test 'vector 572 | 'nibbles:read-ub64/be-sequence 573 | 'nibbles:write-ub64/be-sequence 64 nil t) 574 | :ok) 575 | 576 | (rtest:deftest :write-sb64/be-vector 577 | (write-sequence-test 'vector 578 | 'nibbles:read-sb64/be-sequence 579 | 'nibbles:write-sb64/be-sequence 64 t t) 580 | :ok) 581 | 582 | (rtest:deftest :write-ub16/le-vector 583 | (write-sequence-test 'vector 584 | 'nibbles:read-ub16/le-sequence 585 | 'nibbles:write-ub16/le-sequence 16 nil nil) 586 | :ok) 587 | 588 | (rtest:deftest :write-sb16/le-vector 589 | (write-sequence-test 'vector 590 | 'nibbles:read-sb16/le-sequence 591 | 'nibbles:write-sb16/le-sequence 16 t nil) 592 | :ok) 593 | 594 | (rtest:deftest :write-ub32/le-vector 595 | (write-sequence-test 'vector 596 | 'nibbles:read-ub32/le-sequence 597 | 'nibbles:write-ub32/le-sequence 32 nil nil) 598 | :ok) 599 | 600 | (rtest:deftest :write-sb32/le-vector 601 | (write-sequence-test 'vector 602 | 'nibbles:read-sb32/le-sequence 603 | 'nibbles:write-sb32/le-sequence 32 t nil) 604 | :ok) 605 | 606 | (rtest:deftest :write-ub64/le-vector 607 | (write-sequence-test 'vector 608 | 'nibbles:read-ub64/le-sequence 609 | 'nibbles:write-ub64/le-sequence 64 nil nil) 610 | :ok) 611 | 612 | (rtest:deftest :write-sb64/le-vector 613 | (write-sequence-test 'vector 614 | 'nibbles:read-sb64/le-sequence 615 | 'nibbles:write-sb64/le-sequence 64 t nil) 616 | :ok) 617 | 618 | (rtest:deftest :write-ub16/be-list 619 | (write-sequence-test 'list 620 | 'nibbles:read-ub16/be-sequence 621 | 'nibbles:write-ub16/be-sequence 16 nil t) 622 | :ok) 623 | 624 | (rtest:deftest :write-sb16/be-list 625 | (write-sequence-test 'list 626 | 'nibbles:read-sb16/be-sequence 627 | 'nibbles:write-sb16/be-sequence 16 t t) 628 | :ok) 629 | 630 | (rtest:deftest :write-ub32/be-list 631 | (write-sequence-test 'list 632 | 'nibbles:read-ub32/be-sequence 633 | 'nibbles:write-ub32/be-sequence 32 nil t) 634 | :ok) 635 | 636 | (rtest:deftest :write-sb32/be-list 637 | (write-sequence-test 'list 638 | 'nibbles:read-sb32/be-sequence 639 | 'nibbles:write-sb32/be-sequence 32 t t) 640 | :ok) 641 | 642 | (rtest:deftest :write-ub64/be-list 643 | (write-sequence-test 'list 644 | 'nibbles:read-ub64/be-sequence 645 | 'nibbles:write-ub64/be-sequence 64 nil t) 646 | :ok) 647 | 648 | (rtest:deftest :write-sb64/be-list 649 | (write-sequence-test 'list 650 | 'nibbles:read-sb64/be-sequence 651 | 'nibbles:write-sb64/be-sequence 64 t t) 652 | :ok) 653 | 654 | (rtest:deftest :write-ub16/le-list 655 | (write-sequence-test 'list 656 | 'nibbles:read-ub16/le-sequence 657 | 'nibbles:write-ub16/le-sequence 16 nil nil) 658 | :ok) 659 | 660 | (rtest:deftest :write-sb16/le-list 661 | (write-sequence-test 'list 662 | 'nibbles:read-sb16/le-sequence 663 | 'nibbles:write-sb16/le-sequence 16 t nil) 664 | :ok) 665 | 666 | (rtest:deftest :write-ub32/le-list 667 | (write-sequence-test 'list 668 | 'nibbles:read-ub32/le-sequence 669 | 'nibbles:write-ub32/le-sequence 32 nil nil) 670 | :ok) 671 | 672 | (rtest:deftest :write-sb32/le-list 673 | (write-sequence-test 'list 674 | 'nibbles:read-sb32/le-sequence 675 | 'nibbles:write-sb32/le-sequence 32 t nil) 676 | :ok) 677 | 678 | (rtest:deftest :write-ub64/le-list 679 | (write-sequence-test 'list 680 | 'nibbles:read-ub64/le-sequence 681 | 'nibbles:write-ub64/le-sequence 64 nil nil) 682 | :ok) 683 | 684 | (rtest:deftest :write-sb64/le-list 685 | (write-sequence-test 'list 686 | 'nibbles:read-sb64/le-sequence 687 | 'nibbles:write-sb64/le-sequence 64 t nil) 688 | :ok) 689 | -------------------------------------------------------------------------------- /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 19 | &key 20 | (:initial-element octet)) 21 | octet-vector) 22 | make-octet-vector) 23 | (inline make-octet-vector)) 24 | 25 | (defun make-octet-vector (count 26 | &key 27 | (initial-element 0)) 28 | "Make and return an `octet-vector' with COUNT elements. 29 | 30 | If supplied, INITIAL-ELEMENT is used to populate the vector. The value 31 | of INITIAL-ELEMENT has to of type `octet'. " 32 | (make-array count 33 | :element-type 'octet 34 | :initial-element initial-element)) 35 | 36 | (declaim (ftype (function (&rest octet) octet-vector) octet-vector) 37 | (inline octet-vector)) 38 | 39 | (defun octet-vector (&rest args) 40 | "Make and return an `octet-vector' containing the elements ARGS. 41 | ARGS have to be of type `octet'." 42 | (make-array (length args) 43 | :element-type 'octet 44 | :initial-contents args 45 | :adjustable nil 46 | :fill-pointer nil)) 47 | 48 | 49 | ;;; Type `simple-octet-vector' 50 | ;; 51 | 52 | (deftype simple-octet-vector (&optional (length '*)) 53 | #+(or sbcl cmu) `(simple-array octet (,length)) 54 | #-(or sbcl cmu) `(array octet (,length))) 55 | -------------------------------------------------------------------------------- /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 32) 56 | (define-fetchers-and-storers 64)) 57 | 58 | (defun not-supported () 59 | (error "not supported")) 60 | 61 | #+sbcl (declaim (sb-ext:maybe-inline ieee-single-ref/be)) 62 | (defun ieee-single-ref/be (vector index) 63 | (declare (ignorable vector index)) 64 | #+abcl 65 | (system::make-single-float (sb32ref/be vector index)) 66 | #+allegro 67 | (let ((high (ub16ref/be vector index)) 68 | (low (ub16ref/be vector (+ index 2)))) 69 | (excl:shorts-to-single-float high low)) 70 | #+ccl 71 | (ccl::host-single-float-from-unsigned-byte-32 (ub32ref/be vector index)) 72 | #+cmu 73 | (kernel:make-single-float (sb32ref/be vector index)) 74 | #+lispworks 75 | (let* ((ub (ub32ref/be vector index)) 76 | (v (sys:make-typed-aref-vector 4))) 77 | (declare (optimize (speed 3) (float 0) (safety 0))) 78 | (declare (dynamic-extent v)) 79 | (setf (sys:typed-aref '(unsigned-byte 32) v 0) ub) 80 | (sys:typed-aref 'single-float v 0)) 81 | #+sbcl 82 | (sb-kernel:make-single-float (sb32ref/be vector index)) 83 | #-(or abcl allegro ccl cmu lispworks sbcl) 84 | (not-supported)) 85 | 86 | #+sbcl (declaim (sb-ext:maybe-inline ieee-single-sef/be)) 87 | (defun ieee-single-set/be (vector index value) 88 | (declare (ignorable value vector index)) 89 | #+abcl 90 | (progn 91 | (setf (sb32ref/be vector index) (system:single-float-bits value)) 92 | value) 93 | #+allegro 94 | (multiple-value-bind (high low) (excl:single-float-to-shorts value) 95 | (setf (ub16ref/be vector index) high 96 | (ub16ref/be vector (+ index 2)) low) 97 | value) 98 | #+ccl 99 | (progn 100 | (setf (ub32ref/be vector index) (ccl::single-float-bits value)) 101 | value) 102 | #+cmu 103 | (progn 104 | (setf (sb32ref/be vector index) (kernel:single-float-bits value)) 105 | value) 106 | #+lispworks 107 | (let* ((v (sys:make-typed-aref-vector 4))) 108 | (declare (optimize (speed 3) (float 0) (safety 0))) 109 | (declare (dynamic-extent v)) 110 | (setf (sys:typed-aref 'single-float v 0) value) 111 | (setf (ub32ref/be vector index) (sys:typed-aref '(unsigned-byte 32) v 0)) 112 | value) 113 | #+sbcl 114 | (progn 115 | (setf (sb32ref/be vector index) (sb-kernel:single-float-bits value)) 116 | value) 117 | #-(or abcl allegro ccl cmu lispworks sbcl) 118 | (not-supported)) 119 | (defsetf ieee-single-ref/be ieee-single-set/be) 120 | 121 | #+sbcl (declaim (sb-ext:maybe-inline ieee-single-ref/le)) 122 | (defun ieee-single-ref/le (vector index) 123 | (declare (ignorable vector index)) 124 | #+abcl 125 | (system::make-single-float (sb32ref/le vector index)) 126 | #+allegro 127 | (let ((low (ub16ref/le vector index)) 128 | (high (ub16ref/le vector (+ index 2)))) 129 | (excl:shorts-to-single-float high low)) 130 | #+ccl 131 | (ccl::host-single-float-from-unsigned-byte-32 (ub32ref/le vector index)) 132 | #+cmu 133 | (kernel:make-single-float (sb32ref/le vector index)) 134 | #+lispworks 135 | (let* ((ub (ub32ref/le vector index)) 136 | (v (sys:make-typed-aref-vector 4))) 137 | (declare (optimize (speed 3) (float 0) (safety 0))) 138 | (declare (dynamic-extent v)) 139 | (setf (sys:typed-aref '(unsigned-byte 32) v 0) ub) 140 | (sys:typed-aref 'single-float v 0)) 141 | #+sbcl 142 | (sb-kernel:make-single-float (sb32ref/le vector index)) 143 | #-(or abcl allegro ccl cmu lispworks sbcl) 144 | (not-supported)) 145 | 146 | #+sbcl (declaim (sb-ext:maybe-inline ieee-single-set/le)) 147 | (defun ieee-single-set/le (vector index value) 148 | (declare (ignorable value vector index)) 149 | #+abcl 150 | (progn 151 | (setf (sb32ref/le vector index) (system:single-float-bits value)) 152 | value) 153 | #+allegro 154 | (multiple-value-bind (high low) (excl:single-float-to-shorts value) 155 | (setf (ub16ref/le vector index) low 156 | (ub16ref/le vector (+ index 2)) high) 157 | value) 158 | #+ccl 159 | (progn 160 | (setf (ub32ref/le vector index) (ccl::single-float-bits value)) 161 | value) 162 | #+cmu 163 | (progn 164 | (setf (sb32ref/le vector index) (kernel:single-float-bits value)) 165 | value) 166 | #+lispworks 167 | (let* ((v (sys:make-typed-aref-vector 4))) 168 | (declare (optimize (speed 3) (float 0) (safety 0))) 169 | (declare (dynamic-extent v)) 170 | (setf (sys:typed-aref 'single-float v 0) value) 171 | (setf (ub32ref/le vector index) (sys:typed-aref '(unsigned-byte 32) v 0)) 172 | value) 173 | #+sbcl 174 | (progn 175 | (setf (sb32ref/le vector index) (sb-kernel:single-float-bits value)) 176 | value) 177 | #-(or abcl allegro ccl cmu lispworks sbcl) 178 | (not-supported)) 179 | (defsetf ieee-single-ref/le ieee-single-set/le) 180 | 181 | #+sbcl (declaim (sb-ext:maybe-inline ieee-double-ref/be)) 182 | (defun ieee-double-ref/be (vector index) 183 | (declare (ignorable vector index)) 184 | #+abcl 185 | (let ((upper (sb32ref/be vector index)) 186 | (lower (ub32ref/be vector (+ index 4)))) 187 | (system:make-double-float (logior (ash upper 32) lower))) 188 | #+allegro 189 | (let ((u3 (ub16ref/be vector index)) 190 | (u2 (ub16ref/be vector (+ index 2))) 191 | (u1 (ub16ref/be vector (+ index 4))) 192 | (u0 (ub16ref/be vector (+ index 6)))) 193 | (excl:shorts-to-double-float u3 u2 u1 u0)) 194 | #+ccl 195 | (let ((upper (ub32ref/be vector index)) 196 | (lower (ub32ref/be vector (+ index 4)))) 197 | (ccl::double-float-from-bits upper lower)) 198 | #+cmu 199 | (let ((upper (sb32ref/be vector index)) 200 | (lower (ub32ref/be vector (+ index 4)))) 201 | (kernel:make-double-float upper lower)) 202 | #+sbcl 203 | (let ((upper (sb32ref/be vector index)) 204 | (lower (ub32ref/be vector (+ index 4)))) 205 | (sb-kernel:make-double-float upper lower)) 206 | #-(or abcl allegro ccl cmu sbcl) 207 | (not-supported)) 208 | 209 | #+sbcl (declaim (sb-ext:maybe-inline ieee-double-set/be)) 210 | (defun ieee-double-set/be (vector index value) 211 | (declare (ignorable value vector index)) 212 | #+abcl 213 | (progn 214 | (setf (sb32ref/be vector index) (system::double-float-high-bits value) 215 | (ub32ref/be vector (+ index 4)) (system::double-float-low-bits value)) 216 | value) 217 | #+allegro 218 | (multiple-value-bind (us3 us2 us1 us0) (excl:double-float-to-shorts value) 219 | (setf (ub16ref/be vector index) us3 220 | (ub16ref/be vector (+ index 2)) us2 221 | (ub16ref/be vector (+ index 4)) us1 222 | (ub16ref/be vector (+ index 6)) us0) 223 | value) 224 | #+ccl 225 | (multiple-value-bind (upper lower) (ccl::double-float-bits value) 226 | (setf (ub32ref/be vector index) upper 227 | (ub32ref/be vector (+ index 4)) lower) 228 | value) 229 | #+cmu 230 | (progn 231 | (setf (sb32ref/be vector index) (kernel:double-float-high-bits value) 232 | (ub32ref/be vector (+ index 4)) (kernel:double-float-low-bits value)) 233 | value) 234 | #+sbcl 235 | (progn 236 | (setf (sb32ref/be vector index) (sb-kernel:double-float-high-bits value) 237 | (ub32ref/be vector (+ index 4)) (sb-kernel:double-float-low-bits value)) 238 | value) 239 | #-(or abcl allegro ccl cmu sbcl) 240 | (not-supported)) 241 | (defsetf ieee-double-ref/be ieee-double-set/be) 242 | 243 | #+sbcl (declaim (sb-ext:maybe-inline ieee-double-ref/le)) 244 | (defun ieee-double-ref/le (vector index) 245 | (declare (ignorable vector index)) 246 | #+abcl 247 | (let ((lower (ub32ref/le vector index)) 248 | (upper (sb32ref/le vector (+ index 4)))) 249 | (system:make-double-float (logior (ash upper 32) lower))) 250 | #+allegro 251 | (let ((u0 (ub16ref/le vector index)) 252 | (u1 (ub16ref/le vector (+ index 2))) 253 | (u2 (ub16ref/le vector (+ index 4))) 254 | (u3 (ub16ref/le vector (+ index 6)))) 255 | (excl:shorts-to-double-float u3 u2 u1 u0)) 256 | #+ccl 257 | (let ((lower (ub32ref/le vector index)) 258 | (upper (ub32ref/le vector (+ index 4)))) 259 | (ccl::double-float-from-bits upper lower)) 260 | #+cmu 261 | (let ((lower (ub32ref/le vector index)) 262 | (upper (sb32ref/le vector (+ index 4)))) 263 | (kernel:make-double-float upper lower)) 264 | #+sbcl 265 | (let ((lower (ub32ref/le vector index)) 266 | (upper (sb32ref/le vector (+ index 4)))) 267 | (sb-kernel:make-double-float upper lower)) 268 | #-(or abcl allegro ccl cmu sbcl) 269 | (not-supported)) 270 | 271 | #+sbcl (declaim (sb-ext:maybe-inline ieee-double-set/le)) 272 | (defun ieee-double-set/le (vector index value) 273 | (declare (ignorable value vector index)) 274 | #+abcl 275 | (progn 276 | (setf (ub32ref/le vector index) (system::double-float-low-bits value) 277 | (sb32ref/le vector (+ index 4)) (system::double-float-high-bits value)) 278 | value) 279 | #+allegro 280 | (multiple-value-bind (us3 us2 us1 us0) (excl:double-float-to-shorts value) 281 | (setf (ub16ref/le vector index) us0 282 | (ub16ref/le vector (+ index 2)) us1 283 | (ub16ref/le vector (+ index 4)) us2 284 | (ub16ref/le vector (+ index 6)) us3) 285 | value) 286 | #+ccl 287 | (multiple-value-bind (upper lower) (ccl::double-float-bits value) 288 | (setf (ub32ref/le vector index) lower 289 | (ub32ref/le vector (+ index 4)) upper) 290 | value) 291 | #+cmu 292 | (progn 293 | (setf (ub32ref/le vector index) (kernel:double-float-low-bits value) 294 | (sb32ref/le vector (+ index 4)) (kernel:double-float-high-bits value)) 295 | value) 296 | #+sbcl 297 | (progn 298 | (setf (ub32ref/le vector index) (sb-kernel:double-float-low-bits value) 299 | (sb32ref/le vector (+ index 4)) (sb-kernel:double-float-high-bits value)) 300 | value) 301 | #-(or abcl allegro ccl cmu sbcl) 302 | (not-supported)) 303 | (defsetf ieee-double-ref/le ieee-double-set/le) 304 | --------------------------------------------------------------------------------