pax_global_header 0000666 0000000 0000000 00000000064 13057520021 0014505 g ustar 00root root 0000000 0000000 52 comment=9de8c755c2ff24117748a3271e8582bb8d4a6b6c
nibbles-20170403-git/ 0000775 0000000 0000000 00000000000 13057520021 0014146 5 ustar 00root root 0000000 0000000 nibbles-20170403-git/.gitignore 0000664 0000000 0000000 00000000206 13057520021 0016134 0 ustar 00root root 0000000 0000000 *.fasl
*.FASL
*.ufasl
*.ufsl
*.dx32fsl
*.dx64fsl
*.pfsl
*.dfsl
*.p64fsl
*.d64fsl
*.lx32fsl
*.lx64fsl
*.fx32fsl
*.fx64fsl
*.fas
*.lib
nibbles-20170403-git/.travis.yml 0000664 0000000 0000000 00000000745 13057520021 0016265 0 ustar 00root root 0000000 0000000 language: common-lisp
sudo: required
env:
matrix:
- LISP=sbcl
- LISP=ccl
- LISP=clisp
- LISP=abcl
- LISP=allegro
install:
# Install cl-travis
- curl https://raw.githubusercontent.com/luismbo/cl-travis/master/install.sh | bash
script:
- cl -l nibbles -l nibbles-tests
-e '(setf *debugger-hook*
(lambda (&rest ignorable)
(declare (ignore ignorable))
(uiop:quit -1)))'
-e '(rt:do-tests)'
nibbles-20170403-git/LICENSE 0000664 0000000 0000000 00000002744 13057520021 0015162 0 ustar 00root root 0000000 0000000 Copyright (c) 2010, Nathan Froyd
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
* Neither the name of the copyright holders nor the names of
contributors to this software may be used to endorse or promote
products derived from this software without specific prior written
permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
nibbles-20170403-git/NEWS 0000664 0000000 0000000 00000002346 13057520021 0014652 0 ustar 00root root 0000000 0000000 hey emacs, show me an -*- mode: outline -*-
* Version 0.13, released 2017-03-07
** bug fixes
Fixed problems reading elements into lists.
Fixed DEFKNOWN issues on newer SBCL versions. (Thanks to Kenan Bölükbaşı.)
** new features
Float accessors are now supported on ABCL. (Thanks to Robert Brown.)
* Version 0.12, released 2014-10-08
** bug fixes
Better support for Allegro CL modern mode. (Thanks to Markus Flambard.)
More correct code generation for x86-64 SBCL.
** new features
Float accessors are now MAYBE-INLINE on SBCL. (Thanks to Jan Moringen.)
* Version 0.11, released 2013-01-14
** bug fixes
IEEE-DOUBLE-REF/* now works correctly on CCL.
IEEE-SINGLE-REF/* now works correctly on Allegro. (Thanks to Richard
Billington for the bug report.)
** new features
MAKE-OCTET-VECTOR and OCTET-VECTOR convenience functions have been
added, along with the OCTET, OCTET-VECTOR, and SIMPLE-OCTET-VECTOR
types. (Thanks to Jan Moringen.)
Stream readers and writers for floats have been added, analogous to the
existing functions for integers. These functionsn are only supported on
implementations which support the array accessors (SBCL, CCL, CMUCL for
double-floats; all those including Lispworks and Allegro for
single-floats).
nibbles-20170403-git/README 0000664 0000000 0000000 00000002763 13057520021 0015036 0 ustar 00root root 0000000 0000000 When dealing with network protocols and file formats, it's common to
have to read or write 16-, 32-, or 64-bit datatypes in signed or
unsigned flavors. Common Lisp sort of supports this by specifying
:ELEMENT-TYPE for streams, but that facility is underspecified and
there's nothing similar for read/write from octet vectors. What most
people wind up doing is rolling their own small facility for their
particular needs and calling it a day.
This library attempts to be comprehensive and centralize such
facilities. Functions to read 16-, 32-, and 64-bit quantities from
octet vectors in signed or unsigned flavors are provided; these
functions are also SETFable. Since it's sometimes desirable to
read/write directly from streams, functions for doing so are also
provided. On some implementations, reading/writing IEEE singles/doubles
(i.e. SINGLE-FLOAT and DOUBLE-FLOAT) will also be supported.
In addition to centralizing such facilities, NIBBLES also aspires to
become a place where compiler optimizations can be written once and used
everywhere. The intention is that (eventually):
(nibbles:sb32ref/le vector index)
will compile (with any necessary safety checks) to a MOVSX instruction
on an x86oid processor in SBCL (or other implementations) if VECTOR and
INDEX are of appropriate types.
I remember reading a post on comp.lang.lisp that suggested the designers
of Common Lisp ignored the realities of octets and endianness and so
forth. This library is a small step towards remedying that deficiency.
nibbles-20170403-git/doc/ 0000775 0000000 0000000 00000000000 13057520021 0014713 5 ustar 00root root 0000000 0000000 nibbles-20170403-git/doc/index.html 0000664 0000000 0000000 00000016616 13057520021 0016722 0 ustar 00root root 0000000 0000000
nibbles
nibbles
nibbles is a library for accessing multibyte integers from
octet arrays and streams. While such accessors are straightforward to
write, nibbles aims to centralize such facilities and also
provide optimizations for them when appropriate.
It comes with an ASDF system definition, so (ASDF:OOS
'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
much anything you want to with the code except claim that you wrote
it.
Integer array accessors
ub16ref/levectorindex => value ub32ref/levectorindex => value ub64ref/levectorindex => value
This family of functions accesses an unsigned 16-bit, 32-bit or
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:
read-ub16/lestream => value read-ub32/lestream => value read-ub64/lestream => value
This family of functions reads an unsigned 16-bit, 32-bit, or
64-bit value from stream in little-endian order. stream
must have an element-type of (UNSIGNED-BYTE 8).
read-ub16/bestream => value read-ub32/bestream => value read-ub64/bestream => value
As the above, only the value is read in big-endian order.
read-sb16/lestream => value read-sb32/lestream => value read-sb64/lestream => value
read-sb16/bestream => value read-sb32/bestream => value read-sb64/bestream => value
As the above, only the value is signed, rather than unsigned.
Stream writers
write-ub16/leintegerstream => value write-ub32/leintegerstream => value write-ub64/leintegerstream => value
This family of functions writes an unsigned 16-bit, 32-bit, or
64-bit integer to stream in little-endian order. stream
must have an element-type of (UNSIGNED-BYTE 8). The value written
is returned.
write-ub16/beintegerstream => value write-ub32/beintegerstream => value write-ub64/beintegerstream => value
As the above, only the value is read in big-endian order.
write-sb16/leintegerstream => value write-sb32/leintegerstream => value write-sb64/leintegerstream => value
write-sb16/beintegerstream => value write-sb32/beintegerstream => value write-sb64/beintegerstream => value
As the above, only the value is signed, rather than unsigned.
nibbles-20170403-git/doc/nibbles-doc.txt 0000664 0000000 0000000 00000010702 13057520021 0017635 0 ustar 00root root 0000000 0000000 (:author "Nathan Froyd"
:email "froydnj@gmail.com"
:package "nibbles"
:cl-package "NIBBLES"
:version #.(asdf:component-version (asdf:find-system :nibbles))
:homepage "http://www.method-combination.net/lisp/nibbles/"
:download "http://www.method-combination.net/lisp/files/nibbles.tar.gz")
(:h1 ${package})
(:p ${package} " is a library for accessing multibyte integers from
octet arrays and streams. While such accessors are straightforward to
write, " ${package} " aims to centralize such facilities and also
provide optimizations for them when appropriate.")
(:h2 "Installation")
(:p ${package} " can be downloaded at " (:url ${download} ${download})
". The latest version is " ${version} ".")
(:p "It comes with an ASDF system definition, so " `(ASDF:OOS
'ASDF:LOAD-OP :NIBBLES)` " should be all that you need to get started.")
(:h2 "License")
(:p ${package} " is released under a MIT-like license; you can do pretty
much anything you want to with the code except claim that you wrote
it.")
(:h2 "Integer array accessors")
(:describe :accessor (nibbles:ub16ref/le value)
(nibbles:ub32ref/le value)
(nibbles:ub64ref/le value))
(:p "This family of functions accesses an unsigned 16-bit, 32-bit or
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:")
(:pre "CL-USER> (nibbles:ub16ref/le (coerce #(42 53) '(vector (unsigned-byte 8))) 0)
13610
CL-USER> (format nil \"~X\" *)
\"352A\"")
(:describe :accessor (nibbles:ub16ref/be value)
(nibbles:ub32ref/be value)
(nibbles:ub64ref/be value))
(:p "As the above, only the value is accessed in big-endian order. For instance:")
(:pre "CL-USER> (nibbles:ub16ref/be (coerce #(42 53) '(vector (unsigned-byte 8))) 0)
10805
CL-USER> (format nil \"~X\" *)
\"2A35\"")
(:describe :accessor (nibbles:sb16ref/le value)
(nibbles:sb32ref/le value)
(nibbles:sb64ref/le value))
(:describe :accessor (nibbles:sb16ref/be value)
(nibbles:sb32ref/be value)
(nibbles:sb64ref/be value))
(:p "As the above, only the value accessed is a signed value. For instance:")
(:pre "CL-USER> (nibbles:sb16ref/be (coerce #(81 92) '(vector (unsigned-byte 8))) 0)
20828
CL-USER> (nibbles:sb16ref/be (coerce #(129 135) '(vector (unsigned-byte 8))) 0)
-32377
CL-USER> (format nil \"~X ~X\" ** *)
\"515C -7E79\"
CL-USER> (nibbles:sb16ref/le (coerce #(81 92) '(vector (unsigned-byte 8))) 0)
23633
CL-USER> (nibbles:sb16ref/le (coerce #(129 135) '(vector (unsigned-byte 8))) 0)
-30847
CL-USER> (format nil \"~X ~X\" ** *)
\"5C51 -787F\"")
(:h2 "Stream readers")
(:describe :function (nibbles:read-ub16/le value)
(nibbles:read-ub32/le value)
(nibbles:read-ub64/le value))
(:p "This family of functions reads an unsigned 16-bit, 32-bit, or
64-bit value from " 'stream' " in little-endian order. " 'stream' "
must have an element-type of " `(UNSIGNED-BYTE 8)` ".")
(:describe :function (nibbles:read-ub16/be value)
(nibbles:read-ub32/be value)
(nibbles:read-ub64/be value))
(:p "As the above, only the value is read in big-endian order.")
(:describe :function (nibbles:read-sb16/le value)
(nibbles:read-sb32/le value)
(nibbles:read-sb64/le value))
(:describe :function (nibbles:read-sb16/be value)
(nibbles:read-sb32/be value)
(nibbles:read-sb64/be value))
(:p "As the above, only the value is signed, rather than unsigned.")
(:h2 "Stream writers")
(:describe :function (nibbles:write-ub16/le value)
(nibbles:write-ub32/le value)
(nibbles:write-ub64/le value))
(:p "This family of functions writes an unsigned 16-bit, 32-bit, or
64-bit " 'integer' " to " 'stream' " in little-endian order. " 'stream' "
must have an element-type of " `(UNSIGNED-BYTE 8)` ". The value written
is returned.")
(:describe :function (nibbles:write-ub16/be value)
(nibbles:write-ub32/be value)
(nibbles:write-ub64/be value))
(:p "As the above, only the value is read in big-endian order.")
(:describe :function (nibbles:write-sb16/le value)
(nibbles:write-sb32/le value)
(nibbles:write-sb64/le value))
(:describe :function (nibbles:write-sb16/be value)
(nibbles:write-sb32/be value)
(nibbles:write-sb64/be value))
(:p "As the above, only the value is signed, rather than unsigned.")
nibbles-20170403-git/doc/style.css 0000664 0000000 0000000 00000001756 13057520021 0016576 0 ustar 00root root 0000000 0000000 body {
margin: 1em 5% 1em 5%;
}
p {
margin-top: 0.5em;
margin-bottom: 0.5em;
}
pre {
padding: 0;
margin: 0;
}
h1, h2 {
border-bottom: 2px solid #449977;
}
h1, h2, h3, h4, h5, h6 {
font-family: sans-serif;
line-height: 1.3;
}
a:link {
color: #449977;
}
a:visited {
color: purple;
}
a {
text-decoration: none;
padding: 1px 2px;
}
a:hover {
text-decoration: none;
padding: 1px;
border: 1px solid #000000;
}
.lisp-symbol {
margin-right: 10%;
margin-top: 1.5em;
margin-bottom: 1.5em;
border: 1px solid #449977;
background: #eeeeee;
padding: 0.5em;
}
.note {
margin-right: 10%;
margin-top: 1.5em;
margin-bottom: 1.5em;
}
td.content {
padding: 0;
}
td.title {
font-family: sans-serif;
font-size: 1.1em;
font-weight: bold;
text-align: left;
vertical-align: top;
text-decoration: underline;
padding-right: 0.5em;
margin-top: 0.0em;
margin-bottom: 0.5em;
}
.note td.content {
padding-left: 0.5em;
border-left: 2px solid #449977;
}
nibbles-20170403-git/macro-utils.lisp 0000664 0000000 0000000 00000013675 13057520021 0017312 0 ustar 00root root 0000000 0000000 ;;;; macro-utils.lisp -- functions for compile-time macros
(cl:in-package :nibbles)
(defun byte-fun-name (bitsize signedp big-endian-p desc)
(let ((*package* (find-package :nibbles)))
(intern (format nil "~A~D~A/~A"
(symbol-name (if signedp :sb :ub))
bitsize
(symbol-name desc)
(symbol-name (if big-endian-p :be :le))))))
(defun float-fun-name (float-type big-endian-p desc)
(let ((*package* (find-package :nibbles)))
(intern (format nil "~A-~A-~A/~A"
(symbol-name :ieee)
(symbol-name float-type)
(symbol-name desc)
(symbol-name (if big-endian-p :be :le))))))
(defun byte-ref-fun-name (bitsize signedp big-endian-p)
(byte-fun-name bitsize signedp big-endian-p :ref))
(defun float-ref-fun-name (float-type big-endian-p)
(float-fun-name float-type big-endian-p :ref))
(defun byte-set-fun-name (bitsize signedp big-endian-p)
(byte-fun-name bitsize signedp big-endian-p :set))
(defun float-set-fun-name (float-type big-endian-p)
(float-fun-name float-type big-endian-p :set))
(defun stream-ref-fun-name (bitsize readp signedp big-endian-p)
(let ((*package* (find-package :nibbles)))
(intern (format nil "~A-~A~D/~A"
(symbol-name (if readp :read :write))
(symbol-name (if signedp :sb :ub))
bitsize
(symbol-name (if big-endian-p :be :le))))))
(defun stream-float-ref-fun-name (float-type readp big-endian-p)
(let ((*package* (find-package :nibbles)))
(intern (format nil "~A-~A-~A/~A"
(symbol-name (if readp :read :write))
(symbol-name :ieee)
(symbol-name float-type)
(symbol-name (if big-endian-p :be :le))))))
(defun stream-seq-fun-name (bitsize readp signedp big-endian-p)
(let ((*package* (find-package :nibbles)))
(intern (format nil "~A-~A~D/~A-~A"
(symbol-name (if readp :read :write))
(symbol-name (if signedp :sb :ub))
bitsize
(symbol-name (if big-endian-p :be :le))
(symbol-name :sequence)))))
(defun stream-float-seq-fun-name (float-type readp big-endian-p)
(let ((*package* (find-package :nibbles)))
(intern (format nil "~A-~A-~A/~A-~A"
(symbol-name (if readp :read :write))
(symbol-name :ieee)
(symbol-name float-type)
(symbol-name (if big-endian-p :be :le))
(symbol-name :sequence)))))
(defun stream-into-seq-fun-name (bitsize signedp big-endian-p)
(let ((*package* (find-package :nibbles)))
(intern (format nil "~A-~A~D/~A-~A"
(symbol-name :read)
(symbol-name (if signedp :sb :ub))
bitsize
(symbol-name (if big-endian-p :be :le))
(symbol-name :into-sequence)))))
(defun stream-float-into-seq-fun-name (float-type big-endian-p)
(let ((*package* (find-package :nibbles)))
(intern (format nil "~A-~A/~A-~A"
(symbol-name :read-ieee)
(symbol-name float-type)
(symbol-name (if big-endian-p :be :le))
(symbol-name :into-sequence)))))
(defun internalify (s)
(let ((*package* (find-package :nibbles)))
(intern (concatenate 'string "%" (string s)))))
(defun format-docstring (&rest args)
(loop with docstring = (apply #'format nil args)
for start = 0 then (when pos (1+ pos))
for pos = (and start (position #\Space docstring :start start))
while start
collect (subseq docstring start pos) into words
finally (return (format nil "~{~<~%~1,76:;~A~>~^ ~}"
words))))
(defun ref-form (vector-name index-name byte-size signedp big-endian-p)
"Return a form that fetches a SIGNEDP BYTE-SIZE value from VECTOR-NAME,
starting at INDEX-NAME. The value is stored in the vector according to
BIG-ENDIAN-P."
(multiple-value-bind (low high increment compare)
(if big-endian-p
(values 0 (1- byte-size) 1 #'>)
(values (1- byte-size) 0 -1 #'<))
(do ((i (+ low increment) (+ i increment))
(shift (* (- byte-size 2) 8) (- shift 8))
(forms nil))
((funcall compare i high)
`(let* ((high-byte (aref , vector-name
(+ ,index-name ,low)))
;; Would be great if we could just sign-extend along
;; with the load, but this is as good as it gets in
;; portable Common Lisp.
(signed-high ,(if signedp
`(if (logbitp 7 high-byte)
(- high-byte 256)
high-byte)
'high-byte))
(shifted-into-place
(ash signed-high ,(* (1- byte-size) 8))))
(declare (type (unsigned-byte 8) high-byte))
(declare (type (,(if signedp 'signed-byte 'unsigned-byte) 8)
signed-high))
(logior shifted-into-place ,@(nreverse forms))))
(push `(ash (aref ,vector-name
(+ ,index-name ,i))
,shift)
forms))))
(defun set-form (vector-name index-name value-name byte-size big-endian-p)
"Return a form that stores a BYTE-SIZE VALUE-NAME into VECTOR-NAME,
starting at INDEX-NAME. The value is stored in the vector according to
BIG-ENDIAN-P. The form returns VALUE-NAME."
`(progn
,@(loop for i from 1 to byte-size
collect (let ((offset (if big-endian-p
(- byte-size i)
(1- i))))
`(setf (aref ,vector-name
(+ ,index-name ,offset))
(ldb (byte 8 ,(* 8 (1- i))) ,value-name))))
,value-name))
nibbles-20170403-git/nibbles.asd 0000664 0000000 0000000 00000005227 13057520021 0016263 0 ustar 00root root 0000000 0000000 ; -*- mode: lisp -*-
(cl:defpackage :nibbles-system
(:use :cl))
(cl:in-package :nibbles-system)
(defclass nibbles-source-file (asdf:cl-source-file) ())
(defclass txt-file (asdf:doc-file) ((type :initform "txt")))
(defclass css-file (asdf:doc-file) ((type :initform "css")))
(defmethod asdf:perform :around ((op asdf:compile-op) (c nibbles-source-file))
(let ((*print-base* 10) ; INTERN'ing FORMAT'd symbols
(*print-case* :upcase)
#+sbcl (sb-ext:*inline-expansion-limit* (max sb-ext:*inline-expansion-limit* 1000))
#+cmu (ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000)))
(call-next-method)))
(defmethod asdf:perform :around ((op asdf:load-op) (c nibbles-source-file))
(call-next-method))
(asdf:defsystem :nibbles
:version "0.13"
:author "Nathan Froyd "
:maintainer "Nathan Froyd "
:description "A library for accessing octet-addressed blocks of data in big- and little-endian orders"
:license "BSD-style (http://opensource.org/licenses/BSD-3-Clause)"
:default-component-class nibbles-source-file
:components ((:static-file "README")
(:static-file "LICENSE")
(:static-file "NEWS")
(:file "package")
(:file "types" :depends-on ("package"))
(:file "macro-utils" :depends-on ("package"))
(:file "vectors" :depends-on ("types" "macro-utils"))
(:file "streams" :depends-on ("vectors"))
(:module "doc"
:components
((:html-file "index")
(:txt-file "nibbles-doc")
(:css-file "style")))
(:module "sbcl-opt"
:depends-on ("package" "macro-utils")
:components ((:file "fndb")
(:file "nib-tran" :depends-on ("fndb"))
(:file "x86-vm" :depends-on ("fndb"))
(:file "x86-64-vm" :depends-on ("fndb"))))))
(defmethod asdf:perform ((op asdf:test-op)
(c (eql (asdf:find-system :nibbles))))
(asdf:oos 'asdf:test-op 'nibbles-tests))
(asdf:defsystem :nibbles-tests
:depends-on (:nibbles)
:version "0.1"
:author "Nathan Froyd "
:maintainer "Nathan Froyd "
:in-order-to ((asdf:test-op (asdf:load-op :nibbles-tests)))
:components ((:file "rt")
(:file "tests" :depends-on ("rt"))))
(defmethod asdf:perform ((op asdf:test-op)
(c (eql (asdf:find-system :nibbles-tests))))
(or (funcall (intern (symbol-name :do-tests) (find-package :rtest)))
(error "TEST-OP failed for NIBBLES-TESTS")))
nibbles-20170403-git/package.lisp 0000664 0000000 0000000 00000006221 13057520021 0016433 0 ustar 00root root 0000000 0000000 (cl:defpackage :nibbles
(:use :cl)
;; Basic types and constructors.
(:export #:octet #:index
#:octet-vector #:simple-octet-vector
#:make-octet-vector)
;; Basic octet vector accessors.
(:export #:ub16ref/le #:ub16ref/be #:sb16ref/le #:sb16ref/be
#:ub32ref/le #:ub32ref/be #:sb32ref/le #:sb32ref/be
#:ub64ref/le #:ub64ref/be #:sb64ref/le #:sb64ref/be)
;; Stream readers.
(:export #:read-ub16/le #:read-ub16/be #:read-sb16/be #:read-sb16/le
#:read-ub32/le #:read-ub32/be #:read-sb32/be #:read-sb32/le
#:read-ub64/le #:read-ub64/be #:read-sb64/be #:read-sb64/le)
;; Stream readers for vectors.
(:export #:read-ub16/le-sequence #:read-ub16/be-sequence
#:read-sb16/le-sequence #:read-sb16/be-sequence
#:read-ub32/le-sequence #:read-ub32/be-sequence
#:read-sb32/le-sequence #:read-sb32/be-sequence
#:read-ub64/le-sequence #:read-ub64/be-sequence
#:read-sb64/le-sequence #:read-sb64/be-sequence)
;; Non-consing variants akin to READ-SEQUENCE.
(:export #:read-ub16/le-into-sequence #:read-ub16/be-into-sequence
#:read-sb16/le-into-sequence #:read-sb16/be-into-sequence
#:read-ub32/le-into-sequence #:read-ub32/be-into-sequence
#:read-sb32/le-into-sequence #:read-sb32/be-into-sequence
#:read-ub64/le-into-sequence #:read-ub64/be-into-sequence
#:read-sb64/le-into-sequence #:read-sb64/be-into-sequence)
;; Stream writers.
(:export #:write-ub16/le #:write-ub16/be #:write-sb16/be #:write-sb16/le
#:write-ub32/le #:write-ub32/be #:write-sb32/be #:write-sb32/le
#:write-ub64/le #:write-ub64/be #:write-sb64/be #:write-sb64/le)
;; Stream writers for vectors.
(:export #:write-ub16/le-sequence #:write-ub16/be-sequence
#:write-sb16/le-sequence #:write-sb16/be-sequence
#:write-ub32/le-sequence #:write-ub32/be-sequence
#:write-sb32/le-sequence #:write-sb32/be-sequence
#:write-ub64/le-sequence #:write-ub64/be-sequence
#:write-sb64/le-sequence #:write-sb64/be-sequence)
;; The following floating-point functions are not supported on all platforms.
;; Floating-point octet vector accessors.
(:export #:ieee-single-ref/be #:ieee-single-ref/le
#:ieee-double-ref/be #:ieee-double-ref/le)
;; Floating-point stream readers.
(:export #:read-ieee-single/be #:read-ieee-single/le
#:read-ieee-double/be #:read-ieee-double/le)
;; Stream readers for floating-point sequences.
(:export #:read-ieee-single/be-sequence #:read-ieee-single/le-sequence
#:read-ieee-double/be-sequence #:read-ieee-double/le-sequence)
;; Non-consing variants akin to READ-SEQUENCE.
(:export #:read-ieee-single/be-into-sequence #:read-ieee-single/le-into-sequence
#:read-ieee-double/be-into-sequence #:read-ieee-double/le-into-sequence)
;; Stream writers.
(:export #:write-ieee-single/be #:write-ieee-single/le
#:write-ieee-double/be #:write-ieee-double/le)
;; Stream writers for sequences.
(:export #:write-ieee-single/be-sequence #:write-ieee-single/le-sequence
#:write-ieee-double/be-sequence #:write-ieee-double/le-sequence))
nibbles-20170403-git/rt.lisp 0000664 0000000 0000000 00000031372 13057520021 0015472 0 ustar 00root root 0000000 0000000 ;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*-
#|----------------------------------------------------------------------------|
| Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
| |
| Permission to use, copy, modify, and distribute this software and its |
| documentation for any purpose and without fee is hereby granted, provided |
| that this copyright and permission notice appear in all copies and |
| supporting documentation, and that the name of M.I.T. not be used in |
| advertising or publicity pertaining to distribution of the software |
| without specific, written prior permission. M.I.T. makes no |
| representations about the suitability of this software for any purpose. |
| It is provided "as is" without express or implied warranty. |
| |
| M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
| ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
| M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
| ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
| WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
| ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
| SOFTWARE. |
|----------------------------------------------------------------------------|#
(defpackage #:regression-test
(:nicknames #:rtest #-lispworks #:rt)
(:use #:cl)
(:export #:*do-tests-when-defined* #:*test* #:continue-testing
#:deftest #:do-test #:do-tests #:get-test #:pending-tests
#:rem-all-tests #:rem-test)
(:documentation "The MIT regression tester with pfdietz's modifications"))
;;This was the December 19, 1990 version of the regression tester, but
;;has since been modified.
(in-package :regression-test)
(declaim (ftype (function (t) t) get-entry expanded-eval do-entries))
(declaim (type list *entries*))
(declaim (ftype (function (t &rest t) t) report-error))
(declaim (ftype (function (t &optional t) t) do-entry))
(defvar *test* nil "Current test name")
(defvar *do-tests-when-defined* nil)
(defvar *entries* '(nil) "Test database. Has a leading dummy cell that does not contain an entry.")
(defvar *entries-tail* *entries* "Tail of the *entries* list")
(defvar *entries-table* (make-hash-table :test #'equal)
"Map the names of entries to the cons cell in *entries* that precedes the one whose car is the entry.")
(defvar *in-test* nil "Used by TEST")
(defvar *debug* nil "For debugging")
(defvar *catch-errors* t "When true, causes errors in a test to be caught.")
(defvar *print-circle-on-failure* nil
"Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
(defvar *compile-tests* nil "When true, compile the tests before running them.")
(defvar *expanded-eval* nil "When true, convert the tests into a form that is less likely to have compiler optimizations.")
(defvar *optimization-settings* '((safety 3)))
(defvar *expected-failures* nil
"A list of test names that are expected to fail.")
(defvar *notes* (make-hash-table :test 'equal)
"A mapping from names of notes to note objects.")
(defstruct (entry (:conc-name nil))
pend name props form vals)
;;; Note objects are used to attach information to tests.
;;; A typical use is to mark tests that depend on a particular
;;; part of a set of requirements, or a particular interpretation
;;; of the requirements.
(defstruct note
name
contents
disabled ;; When true, tests with this note are considered inactive
)
;; (defmacro vals (entry) `(cdddr ,entry))
(defmacro defn (entry)
(let ((var (gensym)))
`(let ((,var ,entry))
(list* (name ,var) (form ,var) (vals ,var)))))
(defun entry-notes (entry)
(let* ((props (props entry))
(notes (getf props :notes)))
(if (listp notes)
notes
(list notes))))
(defun has-disabled-note (entry)
(let ((notes (entry-notes entry)))
(loop for n in notes
for note = (if (note-p n) n
(gethash n *notes*))
thereis (and note (note-disabled note)))))
(defun pending-tests ()
(loop for entry in (cdr *entries*)
when (and (pend entry) (not (has-disabled-note entry)))
collect (name entry)))
(defun rem-all-tests ()
(setq *entries* (list nil))
(setq *entries-tail* *entries*)
(clrhash *entries-table*)
nil)
(defun rem-test (&optional (name *test*))
(let ((pred (gethash name *entries-table*)))
(when pred
(if (null (cddr pred))
(setq *entries-tail* pred)
(setf (gethash (name (caddr pred)) *entries-table*) pred))
(setf (cdr pred) (cddr pred))
(remhash name *entries-table*)
name)))
(defun get-test (&optional (name *test*))
(defn (get-entry name)))
(defun get-entry (name)
(let ((entry ;; (find name (the list (cdr *entries*))
;; :key #'name :test #'equal)
(cadr (gethash name *entries-table*))
))
(when (null entry)
(report-error t
"~%No test with name ~:@(~S~)."
name))
entry))
(defmacro deftest (name &rest body)
(let* ((p body)
(properties
(loop while (keywordp (first p))
unless (cadr p)
do (error "Poorly formed deftest: ~A~%"
(list* 'deftest name body))
append (list (pop p) (pop p))))
(form (pop p))
(vals p))
`(add-entry (make-entry :pend t
:name ',name
:props ',properties
:form ',form
:vals ',vals))))
(defun add-entry (entry)
(setq entry (copy-entry entry))
(let* ((pred (gethash (name entry) *entries-table*)))
(cond
(pred
(setf (cadr pred) entry)
(report-error nil
"Redefining test ~:@(~S~)"
(name entry)))
(t
(setf (gethash (name entry) *entries-table*) *entries-tail*)
(setf (cdr *entries-tail*) (cons entry nil))
(setf *entries-tail* (cdr *entries-tail*))
)))
(when *do-tests-when-defined*
(do-entry entry))
(setq *test* (name entry)))
(defun report-error (error? &rest args)
(cond (*debug*
(apply #'format t args)
(if error? (throw '*debug* nil)))
(error? (apply #'error args))
(t (apply #'warn args)))
nil)
(defun do-test (&optional (name *test*))
#-sbcl (do-entry (get-entry name))
#+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning))
(do-entry (get-entry name))))
(defun my-aref (a &rest args)
(apply #'aref a args))
(defun my-row-major-aref (a index)
(row-major-aref a index))
(defun equalp-with-case (x y)
"Like EQUALP, but doesn't do case conversion of characters.
Currently doesn't work on arrays of dimension > 2."
(cond
((eq x y) t)
((consp x)
(and (consp y)
(equalp-with-case (car x) (car y))
(equalp-with-case (cdr x) (cdr y))))
((and (typep x 'array)
(= (array-rank x) 0))
(equalp-with-case (my-aref x) (my-aref y)))
((typep x 'vector)
(and (typep y 'vector)
(let ((x-len (length x))
(y-len (length y)))
(and (eql x-len y-len)
(loop
for i from 0 below x-len
for e1 = (my-aref x i)
for e2 = (my-aref y i)
always (equalp-with-case e1 e2))))))
((and (typep x 'array)
(typep y 'array)
(not (equal (array-dimensions x)
(array-dimensions y))))
nil)
((typep x 'array)
(and (typep y 'array)
(let ((size (array-total-size x)))
(loop for i from 0 below size
always (equalp-with-case (my-row-major-aref x i)
(my-row-major-aref y i))))))
(t (eql x y))))
(defun do-entry (entry &optional
(s *standard-output*))
(catch '*in-test*
(setq *test* (name entry))
(setf (pend entry) t)
(let* ((*in-test* t)
;; (*break-on-warnings* t)
(aborted nil)
r)
;; (declare (special *break-on-warnings*))
(block aborted
(setf r
(flet ((%do
()
(cond
(*compile-tests*
(multiple-value-list
(funcall (compile
nil
`(lambda ()
(declare
(optimize ,@*optimization-settings*))
,(form entry))))))
(*expanded-eval*
(multiple-value-list
(expanded-eval (form entry))))
(t
(multiple-value-list
(eval (form entry)))))))
(if *catch-errors*
(handler-bind
(#-ecl (style-warning #'muffle-warning)
(error #'(lambda (c)
(setf aborted t)
(setf r (list c))
(return-from aborted nil))))
(%do))
(%do)))))
(setf (pend entry)
(or aborted
(not (equalp-with-case r (vals entry)))))
(when (pend entry)
(let ((*print-circle* *print-circle-on-failure*))
(format s "~&Test ~:@(~S~) failed~
~%Form: ~S~
~%Expected value~P: ~
~{~S~^~%~17t~}~%"
*test* (form entry)
(length (vals entry))
(vals entry))
(handler-case
(let ((st (format nil "Actual value~P: ~
~{~S~^~%~15t~}.~%"
(length r) r)))
(format s "~A" st))
(error () (format s "Actual value: #~%")
))
(finish-output s)
))))
(when (not (pend entry)) *test*))
(defun expanded-eval (form)
"Split off top level of a form and eval separately. This reduces the chance that
compiler optimizations will fold away runtime computation."
(if (not (consp form))
(eval form)
(let ((op (car form)))
(cond
((eq op 'let)
(let* ((bindings (loop for b in (cadr form)
collect (if (consp b) b (list b nil))))
(vars (mapcar #'car bindings))
(binding-forms (mapcar #'cadr bindings)))
(apply
(the function
(eval `(lambda ,vars ,@(cddr form))))
(mapcar #'eval binding-forms))))
((and (eq op 'let*) (cadr form))
(let* ((bindings (loop for b in (cadr form)
collect (if (consp b) b (list b nil))))
(vars (mapcar #'car bindings))
(binding-forms (mapcar #'cadr bindings)))
(funcall
(the function
(eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form))))
(eval (car binding-forms)))))
((eq op 'progn)
(loop for e on (cdr form)
do (if (null (cdr e)) (return (eval (car e)))
(eval (car e)))))
((and (symbolp op) (fboundp op)
(not (macro-function op))
(not (special-operator-p op)))
(apply (symbol-function op)
(mapcar #'eval (cdr form))))
(t (eval form))))))
(defun continue-testing ()
(if *in-test*
(throw '*in-test* nil)
(do-entries *standard-output*)))
(defun do-tests (&optional
(out *standard-output*))
(dolist (entry (cdr *entries*))
(setf (pend entry) t))
(if (streamp out)
(do-entries out)
(with-open-file
(stream out :direction :output)
(do-entries stream))))
(defun do-entries* (s)
(format s "~&Doing ~A pending test~:P ~
of ~A tests total.~%"
(count t (the list (cdr *entries*)) :key #'pend)
(length (cdr *entries*)))
(finish-output s)
(dolist (entry (cdr *entries*))
(when (and (pend entry)
(not (has-disabled-note entry)))
(format s "~@[~<~%~:; ~:@(~S~)~>~]"
(do-entry entry s))
(finish-output s)
))
(let ((pending (pending-tests))
(expected-table (make-hash-table :test #'equal)))
(dolist (ex *expected-failures*)
(setf (gethash ex expected-table) t))
(let ((new-failures
(loop for pend in pending
unless (gethash pend expected-table)
collect pend)))
(if (null pending)
(format s "~&No tests failed.")
(progn
(format s "~&~A out of ~A ~
total tests failed: ~
~:@(~{~<~% ~1:;~S~>~
~^, ~}~)."
(length pending)
(length (cdr *entries*))
pending)
(if (null new-failures)
(format s "~&No unexpected failures.")
(when *expected-failures*
(format s "~&~A unexpected failures: ~
~:@(~{~<~% ~1:;~S~>~
~^, ~}~)."
(length new-failures)
new-failures)))
))
(finish-output s)
(null pending))))
(defun do-entries (s)
#-sbcl (do-entries* s)
#+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning))
(do-entries* s)))
;;; Note handling functions and macros
(defmacro defnote (name contents &optional disabled)
`(eval-when (:load-toplevel :execute)
(let ((note (make-note :name ',name
:contents ',contents
:disabled ',disabled)))
(setf (gethash (note-name note) *notes*) note)
note)))
(defun disable-note (n)
(let ((note (if (note-p n) n
(setf n (gethash n *notes*)))))
(unless note (error "~A is not a note or note name." n))
(setf (note-disabled note) t)
note))
(defun enable-note (n)
(let ((note (if (note-p n) n
(setf n (gethash n *notes*)))))
(unless note (error "~A is not a note or note name." n))
(setf (note-disabled note) nil)
note))
nibbles-20170403-git/sbcl-opt/ 0000775 0000000 0000000 00000000000 13057520021 0015671 5 ustar 00root root 0000000 0000000 nibbles-20170403-git/sbcl-opt/fndb.lisp 0000664 0000000 0000000 00000003542 13057520021 0017477 0 ustar 00root root 0000000 0000000 ;;;; fndb.lisp -- DEFKNOWNish bits for SBCL
(cl:in-package :nibbles)
#+sbcl (progn
;;; Efficient array bounds checking
(sb-c:defknown %check-bound
((simple-array (unsigned-byte 8) (*)) index (and fixnum sb-vm:word)
(member 2 4 8 16))
index (sb-c:any) :overwrite-fndb-silently t)
;; We DEFKNOWN the exported functions so we can DEFTRANSFORM them.
;; We DEFKNOWN the %-functions so we can DEFINE-VOP them.
#.(loop for i from 0 to #-x86-64 #b0111 #+x86-64 #b1011
for bitsize = (ecase (ldb (byte 2 2) i)
(0 16)
(1 32)
(2 64))
for signedp = (logbitp 1 i)
for setterp = (logbitp 0 i)
for byte-fun = (if setterp
#'byte-set-fun-name
#'byte-ref-fun-name)
for big-fun = (funcall byte-fun bitsize signedp t)
for little-fun = (funcall byte-fun bitsize signedp nil)
for internal-big = (internalify big-fun)
for internal-little = (internalify little-fun)
for arg-type = `(,(if signedp
'signed-byte
'unsigned-byte)
,bitsize)
for external-arg-types = `(array index ,@(when setterp
`(,arg-type)))
for internal-arg-types = (subst '(simple-array (unsigned-byte 8)) 'array
external-arg-types)
collect `(sb-c:defknown (,big-fun ,little-fun) ,external-arg-types
,arg-type (sb-c:any) :overwrite-fndb-silently t) into defknowns
collect `(sb-c:defknown (,internal-big ,internal-little)
,internal-arg-types
,arg-type (sb-c:any) :overwrite-fndb-silently t) into defknowns
finally (return `(progn ,@defknowns)))
);#+sbcl
nibbles-20170403-git/sbcl-opt/nib-tran.lisp 0000664 0000000 0000000 00000010354 13057520021 0020277 0 ustar 00root root 0000000 0000000 ;;;; nib-tran.lisp -- DEFTRANSFORMs for SBCL
(cl:in-package :nibbles)
#+sbcl (progn
(sb-c:deftransform %check-bound ((vector bound offset n-bytes)
((simple-array (unsigned-byte 8) (*)) index
(and fixnum sb-vm:word)
(member 2 4 8 16))
* :node node)
"optimize away bounds check"
;; cf. sb-c::%check-bound transform
(cond ((sb-c:policy node (= sb-c::insert-array-bounds-checks 0))
'offset)
((not (sb-c::constant-lvar-p bound))
(sb-c::give-up-ir1-transform))
(t
(let* ((dim (sb-c::lvar-value bound))
(n-bytes (sb-c::lvar-value n-bytes))
(upper-bound `(integer 0 (,(- dim n-bytes -1)))))
(if (> n-bytes dim)
(sb-c::give-up-ir1-transform)
`(the ,upper-bound offset))))))
#.(flet ((specialized-includep (bitsize signedp setterp)
(declare (ignorable bitsize signedp setterp))
;; Bleh. No good way to solve this atm.
;;
;; Non-x86. No support.
#-(or x86 x86-64)
nil
;; x86 and x86-64. Can do everything.
#+(or x86 x86-64)
t)
(generic-transform-form (fun-name arglist n-bytes
setterp signedp big-endian-p)
(let ((offset-type `(integer 0 ,(- array-dimension-limit n-bytes))))
`(sb-c:deftransform ,fun-name ,arglist
`(locally (declare (type ,',offset-type offset))
,',(if setterp
(set-form 'vector 'offset 'value n-bytes big-endian-p)
(ref-form 'vector 'offset n-bytes signedp big-endian-p)))))))
(loop for i from 0 to #-x86-64 #b0111 #+x86-64 #b1011
for bitsize = (ecase (ldb (byte 2 2) i)
(0 16)
(1 32)
(2 64))
for signedp = (logbitp 1 i)
for setterp = (logbitp 0 i)
for byte-fun = (if setterp
#'byte-set-fun-name
#'byte-ref-fun-name)
for big-fun = (funcall byte-fun bitsize signedp t)
for little-fun = (funcall byte-fun bitsize signedp nil)
for internal-big = (internalify big-fun)
for internal-little = (internalify little-fun)
for n-bytes = (truncate bitsize 8)
for arg-type = `(,(if signedp
'signed-byte
'unsigned-byte)
,bitsize)
for arglist = `(vector offset ,@(when setterp '(value)))
for external-arg-types = `(array index ,@(when setterp
`(,arg-type)))
for internal-arg-types = (subst '(simple-array (unsigned-byte 8)) 'array
external-arg-types)
for transform-arglist = `(,arglist ,internal-arg-types ,arg-type)
for specialized-big-transform
= `(sb-c:deftransform ,big-fun ,transform-arglist
'(,internal-big vector (%check-bound vector (length vector) offset ,n-bytes)
,@(when setterp '(value))))
for specialized-little-transform
= (subst internal-little internal-big
(subst little-fun big-fun
specialized-big-transform))
;; Also include inlining versions for when the argument type
;; is known to be a simple octet vector and we don't have a
;; native assembly implementation.
for generic-big-transform
= (generic-transform-form big-fun transform-arglist n-bytes
setterp signedp t)
for generic-little-transform
= (generic-transform-form little-fun transform-arglist n-bytes
setterp signedp nil)
if (specialized-includep bitsize signedp setterp)
collect specialized-big-transform into transforms
else if (<= bitsize sb-vm:n-word-bits)
collect generic-big-transform into transforms
if (specialized-includep bitsize signedp setterp)
collect specialized-little-transform into transforms
else if (<= bitsize sb-vm:n-word-bits)
collect generic-little-transform into transforms
finally (return `(progn ,@transforms))))
);#+sbcl
nibbles-20170403-git/sbcl-opt/x86-64-vm.lisp 0000664 0000000 0000000 00000014313 13057520021 0020060 0 ustar 00root root 0000000 0000000 ;;;; x86-64-vm.lisp -- VOP definitions SBCL
#+sbcl
(cl:in-package :sb-vm)
#+(and sbcl x86-64) (progn
(define-vop (%check-bound)
(:translate nibbles::%check-bound)
(:policy :fast-safe)
(:args (array :scs (descriptor-reg))
(bound :scs (any-reg))
(index :scs (any-reg)))
(:arg-types simple-array-unsigned-byte-8 positive-fixnum tagged-num
(:constant (member 2 4 8 16)))
(:info offset)
(:temporary (:sc any-reg) temp)
(:results (result :scs (any-reg)))
(:result-types positive-fixnum)
(:vop-var vop)
(:generator 5
(let ((error (generate-error-code vop 'invalid-array-index-error
array bound index)))
;; We want to check the conditions:
;;
;; 0 <= INDEX
;; INDEX < BOUND
;; 0 <= INDEX + OFFSET
;; (INDEX + OFFSET) < BOUND
;;
;; We can do this naively with two unsigned checks:
;;
;; INDEX <_u BOUND
;; INDEX + OFFSET <_u BOUND
;;
;; If INDEX + OFFSET <_u BOUND, though, INDEX must be less than
;; BOUND. We *do* need to check for 0 <= INDEX, but that has
;; already been assured by higher-level machinery.
(inst lea temp (make-ea :qword
:index index :disp (fixnumize offset)))
(inst cmp temp bound)
(inst jmp :a error)
(move result index))))
#.(flet ((frob (bitsize setterp signedp big-endian-p)
(let* ((name (funcall (if setterp
#'nibbles::byte-set-fun-name
#'nibbles::byte-ref-fun-name)
bitsize signedp big-endian-p))
(internal-name (nibbles::internalify name))
(ref-mov-insn (ecase bitsize
(16
(if big-endian-p
'movzx
(if signedp 'movsx 'movzx)))
(32
(if big-endian-p
'mov
(if signedp 'movsxd 'movzxd)))
(64 'mov)))
(result-sc (if signedp 'signed-reg 'unsigned-reg))
(result-type (if signedp 'signed-num 'unsigned-num)))
(flet ((swap-tn-inst-form (tn-name)
(if (= bitsize 16)
`(inst rol ,tn-name 8)
`(inst bswap ,tn-name))))
`(define-vop (,name)
(:translate ,internal-name)
(:policy :fast-safe)
(:args (vector :scs (descriptor-reg))
(index :scs (immediate unsigned-reg))
,@(when setterp
`((value* :scs (,result-sc) :target result))))
(:arg-types simple-array-unsigned-byte-8
positive-fixnum
,@(when setterp
`(,result-type)))
,@(when (and setterp big-endian-p)
`((:temporary (:sc unsigned-reg
:from (:load 0)
:to (:result 0)) temp)))
(:results (result :scs (,result-sc)))
(:result-types ,result-type)
(:generator 3
(let* ((base-disp (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag))
(operand-size ,(ecase bitsize
(16 :word)
(32 :dword)
(64 :qword)))
(result-in-size (reg-in-size result operand-size))
,@(when setterp
'((value (reg-in-size value* operand-size))))
,@(when (and setterp big-endian-p)
'((temp (reg-in-size temp operand-size))))
(memref (sc-case index
(immediate
(make-ea operand-size :base vector
:disp (+ (tn-value index) base-disp)))
(t
(make-ea operand-size
:base vector :index index
:disp base-disp)))))
(declare (ignorable result-in-size))
,@(when (and setterp big-endian-p)
`((inst mov temp value)
,(swap-tn-inst-form 'temp)))
,(if setterp
`(inst mov memref ,(if big-endian-p
'temp
'value))
`(inst ,ref-mov-insn
,(if (and big-endian-p (= bitsize 32))
'result-in-size
'result)
memref))
,@(if setterp
'((move result value*))
(when big-endian-p
`(,(swap-tn-inst-form (if (/= bitsize 64)
'result-in-size
'result))
,(when (and (/= bitsize 64) signedp)
`(inst movsx result result-in-size))))))))))))
(loop for i from 0 upto #b10111
for bitsize = (ecase (ldb (byte 2 3) i)
(0 16)
(1 32)
(2 64))
for setterp = (logbitp 2 i)
for signedp = (logbitp 1 i)
for big-endian-p = (logbitp 0 i)
collect (frob bitsize setterp signedp big-endian-p) into forms
finally (return `(progn ,@forms))))
);#+(and sbcl x86-64)
nibbles-20170403-git/sbcl-opt/x86-vm.lisp 0000664 0000000 0000000 00000016523 13057520021 0017636 0 ustar 00root root 0000000 0000000 ;;;; x86-vm.lisp -- VOP definitions for SBCL
#+sbcl
(cl:in-package :sb-vm)
#+(and sbcl x86) (progn
(define-vop (%check-bound)
(:translate nibbles::%check-bound)
(:policy :fast-safe)
(:args (array :scs (descriptor-reg))
(bound :scs (any-reg))
(index :scs (any-reg)))
(:arg-types simple-array-unsigned-byte-8 positive-fixnum tagged-num
(:constant (member 2 4 8 16)))
(:info offset)
(:temporary (:sc any-reg) temp)
(:results (result :scs (any-reg)))
(:result-types positive-fixnum)
(:vop-var vop)
(:generator 5
(let ((error (generate-error-code vop 'invalid-array-index-error
array bound index)))
;; We want to check the conditions:
;;
;; 0 <= INDEX
;; INDEX < BOUND
;; 0 <= INDEX + OFFSET
;; (INDEX + OFFSET) < BOUND
;;
;; We can do this naively with two unsigned checks:
;;
;; INDEX <_u BOUND
;; INDEX + OFFSET <_u BOUND
;;
;; If INDEX + OFFSET <_u BOUND, though, INDEX must be less than
;; BOUND. We *do* need to check for 0 <= INDEX, but that has
;; already been assured by higher-level machinery.
(inst lea temp (make-ea :dword :index index :disp (fixnumize offset)))
(inst cmp temp bound)
(inst jmp :a error)
(move result index))))
#.(flet ((frob (setterp signedp big-endian-p)
(let* ((name (funcall (if setterp
#'nibbles::byte-set-fun-name
#'nibbles::byte-ref-fun-name)
16 signedp big-endian-p))
(internal-name (nibbles::internalify name))
(result-sc (if signedp 'signed-reg 'unsigned-reg))
(result-type (if signedp 'signed-num 'unsigned-num)))
`(define-vop (,name)
(:translate ,internal-name)
(:policy :fast-safe)
(:args (vector :scs (descriptor-reg))
(index :scs (immediate unsigned-reg))
,@(when setterp
`((value :scs (,result-sc) :target result))))
(:arg-types simple-array-unsigned-byte-8
positive-fixnum
,@(when setterp
`(,result-type)))
,@(when (or setterp big-endian-p)
`((:temporary (:sc unsigned-reg :offset eax-offset
:from ,(if setterp
'(:load 0)
'(:argument 2))
:to (:result 0)) eax)))
(:results (result :scs (,result-sc)))
(:result-types ,result-type)
(:generator 3
(let* ((base-disp (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag))
(memref (sc-case index
(immediate
(make-ea :word :base vector
:disp (+ (tn-value index) base-disp)))
(t
(make-ea :word :base vector
:index index
:disp base-disp)))))
,(when setterp
'(move eax value))
,(when (and setterp big-endian-p)
'(inst rol ax-tn 8))
,(if setterp
'(inst mov memref ax-tn)
`(inst ,(if big-endian-p
'mov
(if signedp
'movsx
'movzx))
,(if big-endian-p
'ax-tn
'result)
memref))
,@(if setterp
'((move result value))
(when big-endian-p
`(eax ; hack so that it looks used
(inst rol ax-tn 8)
(inst ,(if signedp 'movsx 'movzx)
result ax-tn))))))))))
(loop for i from 0 upto #b111
for setterp = (logbitp 2 i)
for signedp = (logbitp 1 i)
for big-endian-p = (logbitp 0 i)
collect (frob setterp signedp big-endian-p) into forms
finally (return `(progn ,@forms))))
#.(flet ((frob (setterp signedp big-endian-p)
(let* ((name (funcall (if setterp
#'nibbles::byte-set-fun-name
#'nibbles::byte-ref-fun-name)
32 signedp big-endian-p))
(internal-name (nibbles::internalify name))
(result-sc (if signedp 'signed-reg 'unsigned-reg))
(result-type (if signedp 'signed-num 'unsigned-num)))
`(define-vop (,name)
(:translate ,internal-name)
(:policy :fast-safe)
(:args (vector :scs (descriptor-reg))
(index :scs (immediate unsigned-reg))
,@(when setterp
`((value :scs (,result-sc) :target result))))
(:arg-types simple-array-unsigned-byte-8
positive-fixnum
,@(when setterp
`(,result-type)))
,@(when (and setterp big-endian-p)
`((:temporary (:sc unsigned-reg
:from (:load 0)
:to (:result 0)) temp)))
(:results (result :scs (,result-sc)))
(:result-types ,result-type)
(:generator 3
(let* ((base-disp (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag))
(memref (sc-case index
(immediate
(make-ea :dword :base vector
:disp (+ (tn-value index) base-disp)))
(t
(make-ea :dword :base vector :index index
:disp base-disp)))))
,@(when (and setterp big-endian-p)
`((inst mov temp value)
(inst bswap temp)))
,(if setterp
`(inst mov memref ,(if big-endian-p
'temp
'value))
'(inst mov result memref))
,(if setterp
'(move result value)
(when big-endian-p
'(inst bswap result)))))))))
(loop for i from 0 upto #b111
for setterp = (logbitp 2 i)
for signedp = (logbitp 1 i)
for big-endian-p = (logbitp 0 i)
collect (frob setterp signedp big-endian-p) into forms
finally (return `(progn ,@forms))))
);#+(and sbcl x86)
nibbles-20170403-git/streams.lisp 0000664 0000000 0000000 00000017026 13057520021 0016523 0 ustar 00root root 0000000 0000000 ;;;; streams.lisp -- reading/writing signed/unsigned bytes to streams
(cl:in-package :nibbles)
(defun read-n-bytes-into (stream n-bytes v)
(dotimes (i n-bytes v)
;; READ-SEQUENCE would likely be more efficient here, but it does
;; not have the semantics we want--in particular, the blocking
;; semantics of READ-SEQUENCE are potentially bad. It's not clear
;; that READ-BYTE is any better here, though...
(setf (aref v i) (read-byte stream))))
(declaim (inline read-byte* write-byte*))
(defun read-byte* (stream n-bytes reffer)
(let ((v (make-array n-bytes :element-type '(unsigned-byte 8))))
(declare (dynamic-extent v))
(read-n-bytes-into stream n-bytes v)
(funcall reffer v 0)))
(defun write-byte* (integer stream n-bytes setter)
(let ((v (make-array n-bytes :element-type '(unsigned-byte 8))))
(declare (dynamic-extent v))
(funcall setter v 0 integer)
(write-sequence v stream)
integer))
(declaim (inline read-into-vector*))
(defun read-into-vector* (stream vector start end n-bytes reffer)
(declare (type function reffer))
(let ((v (make-array n-bytes :element-type '(unsigned-byte 8))))
(declare (dynamic-extent v))
(loop for i from start below end
do (read-n-bytes-into stream n-bytes v)
(setf (aref vector i) (funcall reffer v 0))
finally (return vector))))
(defun read-into-list* (stream list start end n-bytes reffer)
(declare (type function reffer))
(do ((end (or end (length list)))
(v (make-array n-bytes :element-type '(unsigned-byte 8)))
(rem (nthcdr start list) (rest rem))
(i start (1+ i)))
((or (endp rem) (>= i end)) list)
(declare (dynamic-extent v))
(read-n-bytes-into stream n-bytes v)
(setf (first rem) (funcall reffer v 0))))
(declaim (inline read-fresh-sequence))
(defun read-fresh-sequence (result-type stream count
element-type n-bytes reffer)
(ecase result-type
(list
(let ((list (make-list count)))
(read-into-list* stream list 0 count n-bytes reffer)))
(vector
(let ((vector (make-array count :element-type element-type)))
(read-into-vector* stream vector 0 count n-bytes reffer)))))
(defun write-sequence-with-writer (seq stream start end writer)
(declare (type function writer))
(etypecase seq
(list
(mapc (lambda (e) (funcall writer e stream))
(subseq seq start end))
seq)
(vector
(loop with end = (or end (length seq))
for i from start below end
do (funcall writer (aref seq i) stream)
finally (return seq)))))
(defun read-into-sequence (seq stream start end n-bytes reffer)
(etypecase seq
(list
(read-into-list* stream seq start end n-bytes reffer))
(vector
(let ((end (or end (length seq))))
(read-into-vector* stream seq start end n-bytes reffer)))))
#.(loop for i from 0 upto #b10111
for bitsize = (ecase (ldb (byte 2 3) i)
(0 16)
(1 32)
(2 64))
for readp = (logbitp 2 i)
for signedp = (logbitp 1 i)
for big-endian-p = (logbitp 0 i)
for name = (stream-ref-fun-name bitsize readp signedp big-endian-p)
for n-bytes = (truncate bitsize 8)
for byte-fun = (if readp
(byte-ref-fun-name bitsize signedp big-endian-p)
(byte-set-fun-name bitsize signedp big-endian-p))
for byte-arglist = (if readp '(stream) '(integer stream))
for subfun = (if readp 'read-byte* 'write-byte*)
for element-type = `(,(if signedp 'signed-byte 'unsigned-byte) ,bitsize)
collect `(progn
,@(when readp
`((declaim (ftype (function (t) (values ,element-type &optional)) ,name))))
(defun ,name ,byte-arglist
(,subfun ,@byte-arglist ,n-bytes #',byte-fun))) into forms
if readp
collect `(defun ,(stream-seq-fun-name bitsize t signedp big-endian-p)
(result-type stream count)
,(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)."
bitsize signedp big-endian-p)
(read-fresh-sequence result-type stream count
',element-type ,n-bytes #',byte-fun)) into forms
else
collect `(defun ,(stream-seq-fun-name bitsize nil signedp big-endian-p)
(seq stream &key (start 0) end)
,(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)."
bitsize signedp big-endian-p)
(write-sequence-with-writer seq stream start end #',name)) into forms
if readp
collect `(defun ,(stream-into-seq-fun-name bitsize signedp big-endian-p)
(seq stream &key (start 0) end)
,(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)."
bitsize signedp big-endian-p)
(read-into-sequence seq stream start end ,n-bytes #',byte-fun)) into forms
finally (return `(progn ,@forms)))
#.(loop for i from 0 upto #b111
for float-type = (if (logbitp 2 i) 'double 'single)
for readp = (logbitp 1 i)
for big-endian-p = (logbitp 0 i)
for name = (stream-float-ref-fun-name float-type readp big-endian-p)
for n-bytes = (ecase float-type (double 8) (single 4))
for single-fun = (if readp
(float-ref-fun-name float-type big-endian-p)
(float-set-fun-name float-type big-endian-p))
for arglist = (if readp '(stream) '(float stream))
for subfun = (if readp 'read-byte* 'write-byte*)
for element-type = (ecase float-type (double 'double-float) (single 'single-float))
collect `(defun ,name ,arglist
(,subfun ,@arglist ,n-bytes #',single-fun)) into forms
if readp
collect `(defun ,(stream-float-seq-fun-name float-type t big-endian-p)
(result-type stream count)
,(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)."
element-type big-endian-p)
(read-fresh-sequence result-type stream count
',element-type ,n-bytes #',single-fun)) into forms
else
collect `(defun ,(stream-float-seq-fun-name float-type nil big-endian-p)
(seq stream &key (start 0) end)
,(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)."
element-type big-endian-p)
(write-sequence-with-writer seq stream start end #',name)) into forms
if readp
collect `(defun ,(stream-float-into-seq-fun-name float-type big-endian-p)
(seq stream &key (start 0) end)
,(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)."
element-type big-endian-p)
(read-into-sequence seq stream start end ,n-bytes #',single-fun)) into forms
finally (return `(progn ,@forms)))
nibbles-20170403-git/tests.lisp 0000664 0000000 0000000 00000051515 13057520021 0016210 0 ustar 00root root 0000000 0000000 ;;;; tests.lisp -- tests for various bits of functionality
(cl:defpackage :nibbles-tests
(:use :cl))
(cl:in-package :nibbles-tests)
;;; Basic tests for correctness.
(defun make-byte-combiner (n-bytes big-endian-p)
(let ((count 0)
(buffer 0))
#'(lambda (byte)
(setf buffer
(if big-endian-p
(logior (ash buffer 8) byte)
(let ((x (logior (ash byte (* 8 count)) buffer)))
(if (= count n-bytes)
(ash x -8)
x))))
(unless (= count n-bytes)
(incf count))
(cond
((= count n-bytes)
(let ((val (ldb (byte (* 8 n-bytes) 0) buffer)))
(multiple-value-prog1 (values val t)
(setf buffer val))))
(t (values 0 nil))))))
(defun generate-random-octet-vector (n-octets)
(loop with v = (nibbles:make-octet-vector n-octets)
for i from 0 below n-octets
do (setf (aref v i) (random 256))
finally (return v)))
(defun generate-reffed-values (byte-vector bitsize signedp big-endian-p
&optional (rolling-p t))
(do* ((byte-kind (if signedp 'signed-byte 'unsigned-byte))
(bytesize (truncate bitsize 8))
(n-bytes-to-read (if rolling-p
(length byte-vector)
(* (floor (length byte-vector) bytesize)
bytesize)))
(n-values (if rolling-p
(- (length byte-vector) (1- bytesize))
(truncate n-bytes-to-read bytesize)))
(ev (make-array n-values
:element-type `(,byte-kind ,bitsize)
:adjustable t))
(i 0 (1+ i))
(j 0)
(combiner (make-byte-combiner bytesize big-endian-p)))
((>= i n-bytes-to-read) ev)
(multiple-value-bind (aggregate set-p) (funcall combiner (aref byte-vector i))
(when set-p
(setf (aref ev j)
(if (and signedp (logbitp (1- bitsize) aggregate))
(dpb aggregate (byte bitsize 0) -1)
aggregate))
(unless rolling-p
(setf combiner (make-byte-combiner bytesize big-endian-p)))
(incf j)))))
(defvar *default-n-values* 4096)
(defun generate-random-test (bitsize signedp big-endian-p
&optional (n-values *default-n-values*))
(let* ((n-bytes (truncate bitsize 8))
(total-octets (+ n-values (1- n-bytes)))
(random-octets (generate-random-octet-vector total-octets))
(expected-vector
(generate-reffed-values random-octets bitsize signedp big-endian-p)))
(values random-octets expected-vector)))
(defun compile-quietly (form)
(handler-bind ((style-warning #'muffle-warning)
#+sbcl (sb-ext:compiler-note #'muffle-warning))
(compile nil form)))
(defun ref-test (reffer bitsize signedp big-endian-p
&optional (n-octets *default-n-values*))
(multiple-value-bind (byte-vector expected-vector)
(generate-random-test bitsize signedp big-endian-p n-octets)
(flet ((run-test (reffer)
(loop for i from 0 below n-octets
for j from 0
do (let ((reffed-val (funcall reffer byte-vector i))
(expected-val (aref expected-vector j)))
(unless (= reffed-val expected-val)
(error "wanted ~D, got ~D from ~A"
expected-val reffed-val
(subseq byte-vector i
(+ i (truncate bitsize 8))))))
finally (return :ok))))
(run-test reffer)
(when (typep byte-vector '(simple-array (unsigned-byte 8) (*)))
(let ((compiled (compile-quietly
`(lambda (v i)
(declare (type (simple-array (unsigned-byte 8) (*)) v))
(declare (type (integer 0 #.(1- array-dimension-limit)) i))
(declare (optimize speed (debug 0)))
(,reffer v i)))))
(run-test compiled))))))
(defun set-test (reffer bitsize signedp big-endian-p
&optional (n-octets *default-n-values*))
;; We use GET-SETF-EXPANSION to avoid reaching too deeply into
;; internals. This bit relies on knowing that the writer-form will be
;; a simple function call whose CAR is the internal setter, but I
;; think that's a bit better than :: references everywhere.
(multiple-value-bind (vars vals store-vars writer-form reader-form)
(get-setf-expansion `(,reffer x i))
(declare (ignore vars vals store-vars reader-form))
(let ((setter (car writer-form)))
;; Sanity check.
(unless (eq (symbol-package setter) (find-package :nibbles))
(error "need to update setter tests!"))
(multiple-value-bind (byte-vector expected-vector)
(generate-random-test bitsize signedp big-endian-p n-octets)
(flet ((run-test (setter)
(loop with fill-vec = (let ((v (copy-seq byte-vector)))
(fill v 0)
v)
for i from 0 below n-octets
for j from 0
do (funcall setter fill-vec i (aref expected-vector j))
finally (return
(if (mismatch fill-vec byte-vector)
(error "wanted ~A, got ~A" byte-vector fill-vec)
:ok)))))
(run-test setter)
(when (typep byte-vector '(simple-array (unsigned-byte 8) (*)))
(let ((compiled (compile-quietly
`(lambda (v i new)
(declare (type (simple-array (unsigned-byte 8) (*)) v))
(declare (type (integer 0 #.(1- array-dimension-limit)) i))
(declare (type (,(if signedp 'signed-byte 'unsigned-byte)
,bitsize) new))
(declare (optimize speed (debug 0)))
(,setter v i new)))))
(run-test compiled))))))))
;;; Big-endian integer ref tests
(rtest:deftest :ub16ref/be
(ref-test 'nibbles:ub16ref/be 16 nil t)
:ok)
(rtest:deftest :sb16ref/be
(ref-test 'nibbles:sb16ref/be 16 t t)
:ok)
(rtest:deftest :ub32ref/be
(ref-test 'nibbles:ub32ref/be 32 nil t)
:ok)
(rtest:deftest :sb32ref/be
(ref-test 'nibbles:sb32ref/be 32 t t)
:ok)
(rtest:deftest :ub64ref/be
(ref-test 'nibbles:ub64ref/be 64 nil t)
:ok)
(rtest:deftest :sb64ref/be
(ref-test 'nibbles:sb64ref/be 64 t t)
:ok)
;;; Big-endian set tests
(rtest:deftest :ub16set/be
(set-test 'nibbles:ub16ref/be 16 nil t)
:ok)
(rtest:deftest :sb16set/be
(set-test 'nibbles:sb16ref/be 16 t t)
:ok)
(rtest:deftest :ub32set/be
(set-test 'nibbles:ub32ref/be 32 nil t)
:ok)
(rtest:deftest :sb32set/be
(set-test 'nibbles:sb32ref/be 32 t t)
:ok)
(rtest:deftest :ub64set/be
(set-test 'nibbles:ub64ref/be 64 nil t)
:ok)
(rtest:deftest :sb64set/be
(set-test 'nibbles:sb64ref/be 64 t t)
:ok)
;;; Little-endian integer ref tests
(rtest:deftest :ub16ref/le
(ref-test 'nibbles:ub16ref/le 16 nil nil)
:ok)
(rtest:deftest :sb16ref/le
(ref-test 'nibbles:sb16ref/le 16 t nil)
:ok)
(rtest:deftest :ub32ref/le
(ref-test 'nibbles:ub32ref/le 32 nil nil)
:ok)
(rtest:deftest :sb32ref/le
(ref-test 'nibbles:sb32ref/le 32 t nil)
:ok)
(rtest:deftest :ub64ref/le
(ref-test 'nibbles:ub64ref/le 64 nil nil)
:ok)
(rtest:deftest :sb64ref/le
(ref-test 'nibbles:sb64ref/le 64 t nil)
:ok)
;;; Little-endian set tests
(rtest:deftest :ub16set/le
(set-test 'nibbles:ub16ref/le 16 nil nil)
:ok)
(rtest:deftest :sb16set/le
(set-test 'nibbles:sb16ref/le 16 t nil)
:ok)
(rtest:deftest :ub32set/le
(set-test 'nibbles:ub32ref/le 32 nil nil)
:ok)
(rtest:deftest :sb32set/le
(set-test 'nibbles:sb32ref/le 32 t nil)
:ok)
(rtest:deftest :ub64set/le
(set-test 'nibbles:ub64ref/le 64 nil nil)
:ok)
(rtest:deftest :sb64set/le
(set-test 'nibbles:sb64ref/le 64 t nil)
:ok)
;;; Stream reading tests
(defvar *path* #.*compile-file-truename*)
(defun read-file-as-octets (pathname)
(with-open-file (stream pathname :direction :input
:element-type '(unsigned-byte 8))
(let ((v (nibbles:make-octet-vector (file-length stream))))
(read-sequence v stream)
v)))
(defun read-test (reader bitsize signedp big-endian-p)
(let* ((pathname *path*)
(file-contents (read-file-as-octets pathname))
(expected-values (generate-reffed-values file-contents bitsize
signedp big-endian-p)))
(with-open-file (stream pathname :direction :input
:element-type '(unsigned-byte 8))
(loop with n-values = (length expected-values)
for i from 0 below n-values
do (file-position stream i)
(let ((read-value (funcall reader stream))
(expected-value (aref expected-values i)))
(unless (= read-value expected-value)
(return :bad)))
finally (return :ok)))))
(defun read-sequence-test (result-type reader bitsize signedp big-endian-p)
(let* ((pathname *path*)
(file-contents (subseq (read-file-as-octets pathname) 0 8))
(expected-values (generate-reffed-values file-contents bitsize
signedp big-endian-p nil)))
(with-open-file (stream pathname :direction :input
:element-type '(unsigned-byte 8))
(let* ((n-values (truncate (length file-contents)
(truncate bitsize 8)))
(read-values (funcall reader result-type stream n-values)))
(if (or (not (typep read-values result-type))
(mismatch read-values expected-values))
:bad
:ok)))))
(rtest:deftest :read-ub16/be
(read-test 'nibbles:read-ub16/be 16 nil t)
:ok)
(rtest:deftest :read-sb16/be
(read-test 'nibbles:read-sb16/be 16 t t)
:ok)
(rtest:deftest :read-ub32/be
(read-test 'nibbles:read-ub32/be 32 nil t)
:ok)
(rtest:deftest :read-sb32/be
(read-test 'nibbles:read-sb32/be 32 t t)
:ok)
(rtest:deftest :read-ub64/be
(read-test 'nibbles:read-ub64/be 64 nil t)
:ok)
(rtest:deftest :read-sb64/be
(read-test 'nibbles:read-sb64/be 64 t t)
:ok)
(rtest:deftest :read-ub16/le
(read-test 'nibbles:read-ub16/le 16 nil nil)
:ok)
(rtest:deftest :read-sb16/le
(read-test 'nibbles:read-sb16/le 16 t nil)
:ok)
(rtest:deftest :read-ub32/le
(read-test 'nibbles:read-ub32/le 32 nil nil)
:ok)
(rtest:deftest :read-sb32/le
(read-test 'nibbles:read-sb32/le 32 t nil)
:ok)
(rtest:deftest :read-ub64/le
(read-test 'nibbles:read-ub64/le 64 nil nil)
:ok)
(rtest:deftest :read-sb64/le
(read-test 'nibbles:read-sb64/le 64 t nil)
:ok)
(rtest:deftest :read-ub16/be-vector
(read-sequence-test 'vector 'nibbles:read-ub16/be-sequence 16 nil t)
:ok)
(rtest:deftest :read-sb16/be-vector
(read-sequence-test 'vector 'nibbles:read-sb16/be-sequence 16 t t)
:ok)
(rtest:deftest :read-ub32/be-vector
(read-sequence-test 'vector 'nibbles:read-ub32/be-sequence 32 nil t)
:ok)
(rtest:deftest :read-sb32/be-vector
(read-sequence-test 'vector 'nibbles:read-sb32/be-sequence 32 t t)
:ok)
(rtest:deftest :read-ub64/be-vector
(read-sequence-test 'vector 'nibbles:read-ub64/be-sequence 64 nil t)
:ok)
(rtest:deftest :read-sb64/be-vector
(read-sequence-test 'vector 'nibbles:read-sb64/be-sequence 64 t t)
:ok)
(rtest:deftest :read-ub16/le-vector
(read-sequence-test 'vector 'nibbles:read-ub16/le-sequence 16 nil nil)
:ok)
(rtest:deftest :read-sb16/le-vector
(read-sequence-test 'vector 'nibbles:read-sb16/le-sequence 16 t nil)
:ok)
(rtest:deftest :read-ub32/le-vector
(read-sequence-test 'vector 'nibbles:read-ub32/le-sequence 32 nil nil)
:ok)
(rtest:deftest :read-sb32/le-vector
(read-sequence-test 'vector 'nibbles:read-sb32/le-sequence 32 t nil)
:ok)
(rtest:deftest :read-ub64/le-vector
(read-sequence-test 'vector 'nibbles:read-ub64/le-sequence 64 nil nil)
:ok)
(rtest:deftest :read-sb64/le-vector
(read-sequence-test 'vector 'nibbles:read-sb64/le-sequence 64 t nil)
:ok)
(rtest:deftest :read-ub16/be-list
(read-sequence-test 'list 'nibbles:read-ub16/be-sequence 16 nil t)
:ok)
(rtest:deftest :read-sb16/be-list
(read-sequence-test 'list 'nibbles:read-sb16/be-sequence 16 t t)
:ok)
(rtest:deftest :read-ub32/be-list
(read-sequence-test 'list 'nibbles:read-ub32/be-sequence 32 nil t)
:ok)
(rtest:deftest :read-sb32/be-list
(read-sequence-test 'list 'nibbles:read-sb32/be-sequence 32 t t)
:ok)
(rtest:deftest :read-ub64/be-list
(read-sequence-test 'list 'nibbles:read-ub64/be-sequence 64 nil t)
:ok)
(rtest:deftest :read-sb64/be-list
(read-sequence-test 'list 'nibbles:read-sb64/be-sequence 64 t t)
:ok)
(rtest:deftest :read-ub16/le-list
(read-sequence-test 'list 'nibbles:read-ub16/le-sequence 16 nil nil)
:ok)
(rtest:deftest :read-sb16/le-list
(read-sequence-test 'list 'nibbles:read-sb16/le-sequence 16 t nil)
:ok)
(rtest:deftest :read-ub32/le-list
(read-sequence-test 'list 'nibbles:read-ub32/le-sequence 32 nil nil)
:ok)
(rtest:deftest :read-sb32/le-list
(read-sequence-test 'list 'nibbles:read-sb32/le-sequence 32 t nil)
:ok)
(rtest:deftest :read-ub64/le-list
(read-sequence-test 'list 'nibbles:read-ub64/le-sequence 64 nil nil)
:ok)
(rtest:deftest :read-sb64/le-list
(read-sequence-test 'list 'nibbles:read-sb64/le-sequence 64 t nil)
:ok)
;;; Stream writing tests
(defvar *output-directory*
(merge-pathnames (make-pathname :name nil :type nil
:directory '(:relative "test-output"))
(make-pathname :directory (pathname-directory *path*))))
(defun write-test (writer bitsize signedp big-endian-p)
(multiple-value-bind (byte-vector expected-values)
(generate-random-test bitsize signedp big-endian-p)
(let ((tmpfile (make-pathname :name "tmp" :defaults *output-directory*)))
(ensure-directories-exist tmpfile)
(with-open-file (stream tmpfile :direction :output
:element-type '(unsigned-byte 8)
:if-does-not-exist :create
:if-exists :supersede)
(loop with n-values = (length expected-values)
for i from 0 below n-values
do (file-position stream i)
(funcall writer (aref expected-values i) stream)))
(let ((file-contents (read-file-as-octets tmpfile)))
(delete-file tmpfile)
(if (mismatch byte-vector file-contents)
:bad
:ok)))))
(defun read-sequence-from-file (filename seq-type reader n-values)
(with-open-file (stream filename :direction :input
:element-type '(unsigned-byte 8)
:if-does-not-exist :error)
(funcall reader seq-type stream n-values)))
(defun write-sequence-test (seq-type reader writer
bitsize signedp big-endian-p)
(multiple-value-bind (byte-vector expected-values)
(generate-random-test bitsize signedp big-endian-p)
(declare (ignore byte-vector))
(let ((tmpfile (make-pathname :name "tmp" :defaults *output-directory*))
(values-seq (coerce expected-values seq-type)))
(ensure-directories-exist tmpfile)
(flet ((run-random-test (values expected-start expected-end)
(with-open-file (stream tmpfile :direction :output
:element-type '(unsigned-byte 8)
:if-does-not-exist :create
:if-exists :supersede)
(funcall writer values stream :start expected-start
:end expected-end))
(let ((file-contents (read-sequence-from-file tmpfile
seq-type
reader
(- expected-end expected-start))))
(mismatch values file-contents
:start1 expected-start
:end1 expected-end))))
(let* ((block-size (truncate (length expected-values) 4))
(upper-quartile (* block-size 3)))
(unwind-protect
(loop repeat 32
when (run-random-test values-seq (random block-size)
(+ upper-quartile
(random block-size)))
do (return :bad)
finally (return :ok))
(delete-file tmpfile)))))))
(rtest:deftest :write-ub16/be
(write-test 'nibbles:write-ub16/be 16 nil t)
:ok)
(rtest:deftest :write-sb16/be
(write-test 'nibbles:write-sb16/be 16 t t)
:ok)
(rtest:deftest :write-ub32/be
(write-test 'nibbles:write-ub32/be 32 nil t)
:ok)
(rtest:deftest :write-sb32/be
(write-test 'nibbles:write-sb32/be 32 t t)
:ok)
(rtest:deftest :write-ub64/be
(write-test 'nibbles:write-ub64/be 64 nil t)
:ok)
(rtest:deftest :write-sb64/be
(write-test 'nibbles:write-sb64/be 64 t t)
:ok)
(rtest:deftest :write-ub16/le
(write-test 'nibbles:write-ub16/le 16 nil nil)
:ok)
(rtest:deftest :write-sb16/le
(write-test 'nibbles:write-sb16/le 16 t nil)
:ok)
(rtest:deftest :write-ub32/le
(write-test 'nibbles:write-ub32/le 32 nil nil)
:ok)
(rtest:deftest :write-sb32/le
(write-test 'nibbles:write-sb32/le 32 t nil)
:ok)
(rtest:deftest :write-ub64/le
(write-test 'nibbles:write-ub64/le 64 nil nil)
:ok)
(rtest:deftest :write-sb64/le
(write-test 'nibbles:write-sb64/le 64 t nil)
:ok)
(rtest:deftest :write-ub16/be-vector
(write-sequence-test 'vector
'nibbles:read-ub16/be-sequence
'nibbles:write-ub16/be-sequence 16 nil t)
:ok)
(rtest:deftest :write-sb16/be-vector
(write-sequence-test 'vector
'nibbles:read-sb16/be-sequence
'nibbles:write-sb16/be-sequence 16 t t)
:ok)
(rtest:deftest :write-ub32/be-vector
(write-sequence-test 'vector
'nibbles:read-ub32/be-sequence
'nibbles:write-ub32/be-sequence 32 nil t)
:ok)
(rtest:deftest :write-sb32/be-vector
(write-sequence-test 'vector
'nibbles:read-sb32/be-sequence
'nibbles:write-sb32/be-sequence 32 t t)
:ok)
(rtest:deftest :write-ub64/be-vector
(write-sequence-test 'vector
'nibbles:read-ub64/be-sequence
'nibbles:write-ub64/be-sequence 64 nil t)
:ok)
(rtest:deftest :write-sb64/be-vector
(write-sequence-test 'vector
'nibbles:read-sb64/be-sequence
'nibbles:write-sb64/be-sequence 64 t t)
:ok)
(rtest:deftest :write-ub16/le-vector
(write-sequence-test 'vector
'nibbles:read-ub16/le-sequence
'nibbles:write-ub16/le-sequence 16 nil nil)
:ok)
(rtest:deftest :write-sb16/le-vector
(write-sequence-test 'vector
'nibbles:read-sb16/le-sequence
'nibbles:write-sb16/le-sequence 16 t nil)
:ok)
(rtest:deftest :write-ub32/le-vector
(write-sequence-test 'vector
'nibbles:read-ub32/le-sequence
'nibbles:write-ub32/le-sequence 32 nil nil)
:ok)
(rtest:deftest :write-sb32/le-vector
(write-sequence-test 'vector
'nibbles:read-sb32/le-sequence
'nibbles:write-sb32/le-sequence 32 t nil)
:ok)
(rtest:deftest :write-ub64/le-vector
(write-sequence-test 'vector
'nibbles:read-ub64/le-sequence
'nibbles:write-ub64/le-sequence 64 nil nil)
:ok)
(rtest:deftest :write-sb64/le-vector
(write-sequence-test 'vector
'nibbles:read-sb64/le-sequence
'nibbles:write-sb64/le-sequence 64 t nil)
:ok)
(rtest:deftest :write-ub16/be-list
(write-sequence-test 'list
'nibbles:read-ub16/be-sequence
'nibbles:write-ub16/be-sequence 16 nil t)
:ok)
(rtest:deftest :write-sb16/be-list
(write-sequence-test 'list
'nibbles:read-sb16/be-sequence
'nibbles:write-sb16/be-sequence 16 t t)
:ok)
(rtest:deftest :write-ub32/be-list
(write-sequence-test 'list
'nibbles:read-ub32/be-sequence
'nibbles:write-ub32/be-sequence 32 nil t)
:ok)
(rtest:deftest :write-sb32/be-list
(write-sequence-test 'list
'nibbles:read-sb32/be-sequence
'nibbles:write-sb32/be-sequence 32 t t)
:ok)
(rtest:deftest :write-ub64/be-list
(write-sequence-test 'list
'nibbles:read-ub64/be-sequence
'nibbles:write-ub64/be-sequence 64 nil t)
:ok)
(rtest:deftest :write-sb64/be-list
(write-sequence-test 'list
'nibbles:read-sb64/be-sequence
'nibbles:write-sb64/be-sequence 64 t t)
:ok)
(rtest:deftest :write-ub16/le-list
(write-sequence-test 'list
'nibbles:read-ub16/le-sequence
'nibbles:write-ub16/le-sequence 16 nil nil)
:ok)
(rtest:deftest :write-sb16/le-list
(write-sequence-test 'list
'nibbles:read-sb16/le-sequence
'nibbles:write-sb16/le-sequence 16 t nil)
:ok)
(rtest:deftest :write-ub32/le-list
(write-sequence-test 'list
'nibbles:read-ub32/le-sequence
'nibbles:write-ub32/le-sequence 32 nil nil)
:ok)
(rtest:deftest :write-sb32/le-list
(write-sequence-test 'list
'nibbles:read-sb32/le-sequence
'nibbles:write-sb32/le-sequence 32 t nil)
:ok)
(rtest:deftest :write-ub64/le-list
(write-sequence-test 'list
'nibbles:read-ub64/le-sequence
'nibbles:write-ub64/le-sequence 64 nil nil)
:ok)
(rtest:deftest :write-sb64/le-list
(write-sequence-test 'list
'nibbles:read-sb64/le-sequence
'nibbles:write-sb64/le-sequence 64 t nil)
:ok)
nibbles-20170403-git/types.lisp 0000664 0000000 0000000 00000002741 13057520021 0016207 0 ustar 00root root 0000000 0000000 ;;;; types.lisp -- various useful types
(cl:in-package :nibbles)
(deftype octet ()
'(unsigned-byte 8))
(deftype index ()
'(mod #.array-dimension-limit))
;;; Type `octet-vector' and constructors
;;
(deftype octet-vector (&optional (length '*))
`(array octet (,length)))
(declaim (ftype (function (index
&key
(:initial-element octet))
octet-vector)
make-octet-vector)
(inline make-octet-vector))
(defun make-octet-vector (count
&key
(initial-element 0))
"Make and return an `octet-vector' with COUNT elements.
If supplied, INITIAL-ELEMENT is used to populate the vector. The value
of INITIAL-ELEMENT has to of type `octet'. "
(make-array count
:element-type 'octet
:initial-element initial-element))
(declaim (ftype (function (&rest octet) octet-vector) octet-vector)
(inline octet-vector))
(defun octet-vector (&rest args)
"Make and return an `octet-vector' containing the elements ARGS.
ARGS have to be of type `octet'."
(make-array (length args)
:element-type 'octet
:initial-contents args
:adjustable nil
:fill-pointer nil))
;;; Type `simple-octet-vector'
;;
(deftype simple-octet-vector (&optional (length '*))
#+(or sbcl cmu) `(simple-array octet (,length))
#-(or sbcl cmu) `(array octet (,length)))
nibbles-20170403-git/vectors.lisp 0000664 0000000 0000000 00000026562 13057520021 0016537 0 ustar 00root root 0000000 0000000 ;;;; vectors.lisp -- signed/unsigned byte accessors
(cl:in-package :nibbles)
(declaim (inline array-data-and-offsets))
(defun array-data-and-offsets (v start end)
"Like ARRAY-DISPLACEMENT, only more useful."
#+cmu
(lisp::with-array-data ((v v) (start start) (end end))
(values v start end))
#+sbcl
(sb-kernel:with-array-data ((v v) (start start) (end end))
(values v start end))
#-(or cmu sbcl)
(values v start (or end (length v))))
(macrolet ((define-fetcher (bitsize signedp big-endian-p)
(let ((ref-name (byte-ref-fun-name bitsize signedp big-endian-p))
(bytes (truncate bitsize 8)))
`(defun ,ref-name (vector index)
(declare (type octet-vector vector))
(declare (type (integer 0 ,(- array-dimension-limit bytes)) index))
(multiple-value-bind (vector start end)
(array-data-and-offsets vector index (+ index ,bytes))
#+sbcl (declare (optimize (sb-c::insert-array-bounds-checks 0)))
(declare (type (integer 0 ,(- array-dimension-limit bytes)) start))
(declare (ignore end))
,(ref-form 'vector 'start bytes signedp big-endian-p)))))
(define-storer (bitsize signedp big-endian-p)
(let ((ref-name (byte-ref-fun-name bitsize signedp big-endian-p))
(set-name (byte-set-fun-name bitsize signedp big-endian-p))
(bytes (truncate bitsize 8)))
`(progn
(defun ,set-name (vector index value)
(declare (type octet-vector vector))
(declare (type (integer 0 ,(- array-dimension-limit bytes)) index))
(declare (type (,(if signedp
'signed-byte
'unsigned-byte) ,bitsize) value))
(multiple-value-bind (vector start end)
(array-data-and-offsets vector index (+ index ,bytes))
#+sbcl (declare (optimize (sb-c::insert-array-bounds-checks 0)))
(declare (type (integer 0 ,(- array-dimension-limit bytes)) start))
(declare (ignore end))
,(set-form 'vector 'start 'value bytes big-endian-p)))
(defsetf ,ref-name ,set-name))))
(define-fetchers-and-storers (bitsize)
(loop for i from 0 below 4
for signedp = (logbitp 1 i)
for big-endian-p = (logbitp 0 i)
collect `(define-fetcher ,bitsize ,signedp ,big-endian-p) into forms
collect `(define-storer ,bitsize ,signedp ,big-endian-p) into forms
finally (return `(progn ,@forms)))))
(define-fetchers-and-storers 16)
(define-fetchers-and-storers 32)
(define-fetchers-and-storers 64))
(defun not-supported ()
(error "not supported"))
#+sbcl (declaim (sb-ext:maybe-inline ieee-single-ref/be))
(defun ieee-single-ref/be (vector index)
(declare (ignorable vector index))
#+abcl
(system::make-single-float (sb32ref/be vector index))
#+allegro
(let ((high (ub16ref/be vector index))
(low (ub16ref/be vector (+ index 2))))
(excl:shorts-to-single-float high low))
#+ccl
(ccl::host-single-float-from-unsigned-byte-32 (ub32ref/be vector index))
#+cmu
(kernel:make-single-float (sb32ref/be vector index))
#+lispworks
(let* ((ub (ub32ref/be vector index))
(v (sys:make-typed-aref-vector 4)))
(declare (optimize (speed 3) (float 0) (safety 0)))
(declare (dynamic-extent v))
(setf (sys:typed-aref '(unsigned-byte 32) v 0) ub)
(sys:typed-aref 'single-float v 0))
#+sbcl
(sb-kernel:make-single-float (sb32ref/be vector index))
#-(or abcl allegro ccl cmu lispworks sbcl)
(not-supported))
#+sbcl (declaim (sb-ext:maybe-inline ieee-single-sef/be))
(defun ieee-single-set/be (vector index value)
(declare (ignorable value vector index))
#+abcl
(progn
(setf (sb32ref/be vector index) (system:single-float-bits value))
value)
#+allegro
(multiple-value-bind (high low) (excl:single-float-to-shorts value)
(setf (ub16ref/be vector index) high
(ub16ref/be vector (+ index 2)) low)
value)
#+ccl
(progn
(setf (ub32ref/be vector index) (ccl::single-float-bits value))
value)
#+cmu
(progn
(setf (sb32ref/be vector index) (kernel:single-float-bits value))
value)
#+lispworks
(let* ((v (sys:make-typed-aref-vector 4)))
(declare (optimize (speed 3) (float 0) (safety 0)))
(declare (dynamic-extent v))
(setf (sys:typed-aref 'single-float v 0) value)
(setf (ub32ref/be vector index) (sys:typed-aref '(unsigned-byte 32) v 0))
value)
#+sbcl
(progn
(setf (sb32ref/be vector index) (sb-kernel:single-float-bits value))
value)
#-(or abcl allegro ccl cmu lispworks sbcl)
(not-supported))
(defsetf ieee-single-ref/be ieee-single-set/be)
#+sbcl (declaim (sb-ext:maybe-inline ieee-single-ref/le))
(defun ieee-single-ref/le (vector index)
(declare (ignorable vector index))
#+abcl
(system::make-single-float (sb32ref/le vector index))
#+allegro
(let ((low (ub16ref/le vector index))
(high (ub16ref/le vector (+ index 2))))
(excl:shorts-to-single-float high low))
#+ccl
(ccl::host-single-float-from-unsigned-byte-32 (ub32ref/le vector index))
#+cmu
(kernel:make-single-float (sb32ref/le vector index))
#+lispworks
(let* ((ub (ub32ref/le vector index))
(v (sys:make-typed-aref-vector 4)))
(declare (optimize (speed 3) (float 0) (safety 0)))
(declare (dynamic-extent v))
(setf (sys:typed-aref '(unsigned-byte 32) v 0) ub)
(sys:typed-aref 'single-float v 0))
#+sbcl
(sb-kernel:make-single-float (sb32ref/le vector index))
#-(or abcl allegro ccl cmu lispworks sbcl)
(not-supported))
#+sbcl (declaim (sb-ext:maybe-inline ieee-single-set/le))
(defun ieee-single-set/le (vector index value)
(declare (ignorable value vector index))
#+abcl
(progn
(setf (sb32ref/le vector index) (system:single-float-bits value))
value)
#+allegro
(multiple-value-bind (high low) (excl:single-float-to-shorts value)
(setf (ub16ref/le vector index) low
(ub16ref/le vector (+ index 2)) high)
value)
#+ccl
(progn
(setf (ub32ref/le vector index) (ccl::single-float-bits value))
value)
#+cmu
(progn
(setf (sb32ref/le vector index) (kernel:single-float-bits value))
value)
#+lispworks
(let* ((v (sys:make-typed-aref-vector 4)))
(declare (optimize (speed 3) (float 0) (safety 0)))
(declare (dynamic-extent v))
(setf (sys:typed-aref 'single-float v 0) value)
(setf (ub32ref/le vector index) (sys:typed-aref '(unsigned-byte 32) v 0))
value)
#+sbcl
(progn
(setf (sb32ref/le vector index) (sb-kernel:single-float-bits value))
value)
#-(or abcl allegro ccl cmu lispworks sbcl)
(not-supported))
(defsetf ieee-single-ref/le ieee-single-set/le)
#+sbcl (declaim (sb-ext:maybe-inline ieee-double-ref/be))
(defun ieee-double-ref/be (vector index)
(declare (ignorable vector index))
#+abcl
(let ((upper (sb32ref/be vector index))
(lower (ub32ref/be vector (+ index 4))))
(system:make-double-float (logior (ash upper 32) lower)))
#+allegro
(let ((u3 (ub16ref/be vector index))
(u2 (ub16ref/be vector (+ index 2)))
(u1 (ub16ref/be vector (+ index 4)))
(u0 (ub16ref/be vector (+ index 6))))
(excl:shorts-to-double-float u3 u2 u1 u0))
#+ccl
(let ((upper (ub32ref/be vector index))
(lower (ub32ref/be vector (+ index 4))))
(ccl::double-float-from-bits upper lower))
#+cmu
(let ((upper (sb32ref/be vector index))
(lower (ub32ref/be vector (+ index 4))))
(kernel:make-double-float upper lower))
#+sbcl
(let ((upper (sb32ref/be vector index))
(lower (ub32ref/be vector (+ index 4))))
(sb-kernel:make-double-float upper lower))
#-(or abcl allegro ccl cmu sbcl)
(not-supported))
#+sbcl (declaim (sb-ext:maybe-inline ieee-double-set/be))
(defun ieee-double-set/be (vector index value)
(declare (ignorable value vector index))
#+abcl
(progn
(setf (sb32ref/be vector index) (system::double-float-high-bits value)
(ub32ref/be vector (+ index 4)) (system::double-float-low-bits value))
value)
#+allegro
(multiple-value-bind (us3 us2 us1 us0) (excl:double-float-to-shorts value)
(setf (ub16ref/be vector index) us3
(ub16ref/be vector (+ index 2)) us2
(ub16ref/be vector (+ index 4)) us1
(ub16ref/be vector (+ index 6)) us0)
value)
#+ccl
(multiple-value-bind (upper lower) (ccl::double-float-bits value)
(setf (ub32ref/be vector index) upper
(ub32ref/be vector (+ index 4)) lower)
value)
#+cmu
(progn
(setf (sb32ref/be vector index) (kernel:double-float-high-bits value)
(ub32ref/be vector (+ index 4)) (kernel:double-float-low-bits value))
value)
#+sbcl
(progn
(setf (sb32ref/be vector index) (sb-kernel:double-float-high-bits value)
(ub32ref/be vector (+ index 4)) (sb-kernel:double-float-low-bits value))
value)
#-(or abcl allegro ccl cmu sbcl)
(not-supported))
(defsetf ieee-double-ref/be ieee-double-set/be)
#+sbcl (declaim (sb-ext:maybe-inline ieee-double-ref/le))
(defun ieee-double-ref/le (vector index)
(declare (ignorable vector index))
#+abcl
(let ((lower (ub32ref/le vector index))
(upper (sb32ref/le vector (+ index 4))))
(system:make-double-float (logior (ash upper 32) lower)))
#+allegro
(let ((u0 (ub16ref/le vector index))
(u1 (ub16ref/le vector (+ index 2)))
(u2 (ub16ref/le vector (+ index 4)))
(u3 (ub16ref/le vector (+ index 6))))
(excl:shorts-to-double-float u3 u2 u1 u0))
#+ccl
(let ((lower (ub32ref/le vector index))
(upper (ub32ref/le vector (+ index 4))))
(ccl::double-float-from-bits upper lower))
#+cmu
(let ((lower (ub32ref/le vector index))
(upper (sb32ref/le vector (+ index 4))))
(kernel:make-double-float upper lower))
#+sbcl
(let ((lower (ub32ref/le vector index))
(upper (sb32ref/le vector (+ index 4))))
(sb-kernel:make-double-float upper lower))
#-(or abcl allegro ccl cmu sbcl)
(not-supported))
#+sbcl (declaim (sb-ext:maybe-inline ieee-double-set/le))
(defun ieee-double-set/le (vector index value)
(declare (ignorable value vector index))
#+abcl
(progn
(setf (ub32ref/le vector index) (system::double-float-low-bits value)
(sb32ref/le vector (+ index 4)) (system::double-float-high-bits value))
value)
#+allegro
(multiple-value-bind (us3 us2 us1 us0) (excl:double-float-to-shorts value)
(setf (ub16ref/le vector index) us0
(ub16ref/le vector (+ index 2)) us1
(ub16ref/le vector (+ index 4)) us2
(ub16ref/le vector (+ index 6)) us3)
value)
#+ccl
(multiple-value-bind (upper lower) (ccl::double-float-bits value)
(setf (ub32ref/le vector index) lower
(ub32ref/le vector (+ index 4)) upper)
value)
#+cmu
(progn
(setf (ub32ref/le vector index) (kernel:double-float-low-bits value)
(sb32ref/le vector (+ index 4)) (kernel:double-float-high-bits value))
value)
#+sbcl
(progn
(setf (ub32ref/le vector index) (sb-kernel:double-float-low-bits value)
(sb32ref/le vector (+ index 4)) (sb-kernel:double-float-high-bits value))
value)
#-(or abcl allegro ccl cmu sbcl)
(not-supported))
(defsetf ieee-double-ref/le ieee-double-set/le)